Attribute VB_Name = "udf_week2date" '------------------------------------------------------------------------------- 'File : udf_week2date.bas ' Copyright mpl by ERB software ' All rights reserved ' wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/week2date 'Environment : VBA 2007 + 'Version : 1.0.0 'Name : week2date 'Author : Stefan Erb (ERS) 'History : 29.02.2016 - ERS - Creation '------------------------------------------------------------------------------- Option Explicit Private Enum sysLocale LOCALE_IFIRSTDAYOFWEEK = &H100C 'first day of week specifier 0=Mon, 6=Sun https://msdn.microsoft.com/en-us/library/windows/desktop/dd373771%28v=vs.85%29.aspx LOCALE_IFIRSTWEEKOFYEAR = &H100D 'first week of year specifier 0=direct, 1=Full, 2=4days https://msdn.microsoft.com/en-us/library/windows/desktop/dd373772%28v=vs.85%29.aspx End Enum Private Declare Function GetUserDefaultLCID Lib "kernel32" () As Long Private Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long Private Declare Function getLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long '/** ' * Gibt das Datum eines bestimmten Wochentages in einer bestimmten Jahreswoche zurück ' * @param Integer Wochennummer ' * @param VbDayOfWeek Tag der Woche. vbSunday = 1, vbMonday = 2 etc. ' * @param Variant Das Jahr ' * @param vbDayOfWeek Erster Tag der Woche ' * @param vbFirstWeekOfYear Definition der ersten Kalenderwoche im Kalender ' */ Public Function week2date( _ ByVal iWeek As Integer, _ Optional ByVal iWeekDay As VbDayOfWeek = vbUseSystemDayOfWeek, _ Optional ByVal iYear As Variant = Null, _ Optional ByVal iFirstDayOfWeek As VbDayOfWeek = vbUseSystemDayOfWeek, _ Optional ByVal iFirstWeekOfYear As VbFirstWeekOfYear = vbUseSystem _ ) As Date 'Genünschter Wochentag bestimmen Dim weekDay As VbDayOfWeek: weekDay = IIf(iWeekDay = vbUseSystemDayOfWeek, systemFirstDayOfWeek, iWeekDay) 'Erster Januar Dim date1Jan As Date: date1Jan = DateSerial(NZ(iYear, year(Now())), 1, 1) 'Korrektur, falls die Wochennummer aufs Vorjahr fällt + Anzahl Wochen (Wochenzahl -1) Dim deltaWeeks As Integer: deltaWeeks = Abs(DatePart("ww", date1Jan, iFirstDayOfWeek, iFirstWeekOfYear) <> 1) + (iWeek - 1) 'Delta der Wochentagverschiebung berechnen Dim deltaDays As Integer: deltaDays = getDayIdx(weekDay, iFirstDayOfWeek) - getDayIdx(DatePart("w", date1Jan), iFirstDayOfWeek) 'Die Deltas zum 1. Januar dazu rechnen week2date = DateAdd("d", deltaDays + 7 * deltaWeeks, date1Jan) End Function '/** ' * FirstDayOfWeek ausden User/Systemsettings des PC ' * @return vbDayOfWeek Erster Tag der Woche ' */ Private Static Property Get systemFirstDayOfWeek() As VbDayOfWeek Static firstDayOfWeek As VbDayOfWeek If firstDayOfWeek = 0 Then Dim LCID As Long: LCID = GetUserDefaultLCID() If LCID = 0 Then LCID = GetSystemDefaultLCID() If LCID <> 0 Then Dim sReturn As String * 2 '0=Mon, 6=Sun getLocaleInfo LCID, LOCALE_IFIRSTDAYOFWEEK, sReturn, Len(sReturn) firstDayOfWeek = CInt(Trim(sReturn)) + 2 End If If firstDayOfWeek > 7 Then firstDayOfWeek = firstDayOfWeek - 7 End If systemFirstDayOfWeek = firstDayOfWeek End Property '/** ' * Ermittelt den Index eines Wochentages anhand des FirstDayOfWeek. ' * @param vbDayOfWeek Tag der Woche ' * @param vbDayOfWeek Erster Tag der Woche ' * @return Integer Index, 0-6 ' * Private Function getDayIdx(ByVal iWeekDay As VbDayOfWeek, Optional ByVal iFirstDayOfWeek As VbDayOfWeek = vbMonday) As Integer getDayIdx = iWeekDay - iFirstDayOfWeek If getDayIdx < 0 Then getDayIdx = 7 + getDayIdx End Function