Gibt Das Dazum eines bestimmten Wochentages in einer bestimmten Woche des Jahres aus
'Erste Wochentag in der 9ten Woche des aktuellen Jahres ?week2date(9) 29.02.2016 'Freitag derselben Woche ?week2date(9, vbFriday) 04.03.2016 'Wieder den Freitag. Dieses mal mit der Definition, dass die Wochen mit der 1ten Januar-Tag beginnt 'Und das ganze im Jahr 2017 ?week2date(9, vbFriday,,,vbFirstJan1) 26.02.2016 'Und ein Datum in einem bestimmten Jahr ?week2date(9,,2017) 06.03.2017
Falls man das Modul nicht importiert sondern mit Copy-Paste in ein neues Modul kopiert, muss die Zeile Attribute VB_Name = “DDLFile”
weggelassen werden.
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 zurck ' * @param Integer Wochennummer ' * @param VbDayOfWeek Tag der Woche. vbSunday = 1, vbMonday = 2 etc. ' * @param Variant<Long> 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 'Gennschter 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 fllt + 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