143 lines
4.9 KiB
Plaintext
143 lines
4.9 KiB
Plaintext
' GetDateByWeekdayname
|
|
' ----------------------------------------------------------------------------
|
|
' Diese Funktion errechnet das Datum eines übergebenen Wochentages
|
|
' Parameter 1 (pWeekdayname) = Übergabe des zu ermittelnden Wochentags (Bsp.: "Montag","Dienstag","Mittwoch","Donnerstag","Freitag","Samstag","Sonntag")
|
|
' Parameter 2 (pFromDate) = Übergabe des Datums, ab wann gerechnet werden soll (Bsp.: "01.01.2022")
|
|
' Parameter 3 (pIncludeToday) = Übergabe "True" oder "False" um den aktuellen Tag in die Ermittlung einzubeziehen.
|
|
' Parameter 4 (pSkipTodayByTime) = Übergabe einer Uhrzeit (Bsp.: "12:00"), bis wann der aktuelle Tag miteinbezogen werden soll.
|
|
' Sofern nicht mit "99:99" oder "NULL" abgeschaltet, übersteuert Parameter 4 immer Parameter 3.
|
|
'
|
|
' ----------------------------------------------------------------------------
|
|
' Copyright (c) 2021 by Digital Data GmbH
|
|
'
|
|
' Digital Data GmbH • Ludwig-Rinn-Strasse 16 • D-35452 Heuchelheim
|
|
' Tel.: 0641/202360 • E-Mail: info-flow@digitaldata.works
|
|
' ----------------------------------------------------------------------------
|
|
' Creation Date / Author: 05.10.2021 / MK
|
|
' Version Date / Editor: 12.10.2021 / MK
|
|
' Version Number: 1.3.0.0
|
|
|
|
Function GetDateByWeekdayname(pWeekdayname,pFromDate,pIncludeToday,pSkipTodayByTime)
|
|
|
|
'Set vars. Set current date and day and nr
|
|
IF (GetLocale() = 1031) then
|
|
Weekdaynames = Array("Sonntag","Montag","Dienstag","Mittwoch","Donnerstag","Freitag","Samstag")
|
|
Else 'Tag 1 2 3 4 5 6 7
|
|
Weekdaynames = Array("Sunday","Monday","Tuesday","Wednesday","Thursday","Friday","Saturday")
|
|
End if
|
|
|
|
'Evaluate parameter pFromDate
|
|
IF (pFromDate = "today") Then
|
|
FromDate = Date()
|
|
Else
|
|
FromDate = cdate(pFromDate)
|
|
End if
|
|
|
|
IF (IsDate(FromDate) = True) Then
|
|
|
|
CurrentDayNumber = Weekday(FromDate)
|
|
CurrentDayOfWeek = Weekdayname(CurrentDayNumber,False,1)
|
|
CurrentTime = TimeValue(Now())
|
|
|
|
'Evaluate parameter pSkipTodayByTime
|
|
If (pSkipTodayByTime <> "99:99") and (pSkipTodayByTime <> "NULL") Then
|
|
On Error Resume Next
|
|
TimeValue(pSkipTodayByTime)
|
|
If (Err.number = 0) and (CLng(Replace(CurrentTime,":","")) > CLng(Replace(TimeValue(pSkipTodayByTime),":",""))) then
|
|
IncludeToday = False
|
|
Else
|
|
IncludeToday = True
|
|
End if
|
|
|
|
Else
|
|
|
|
'Fallback if parameter ist not bool
|
|
IF (VarType(pIncludeToday) = 11) Then
|
|
IncludeToday = pIncludeToday
|
|
Else
|
|
IncludeToday = False
|
|
End If
|
|
|
|
End if
|
|
|
|
If (DEBUG_ON = True) Or (DebugMode = "Enabled") Then
|
|
MsgBox "Looking for next: " & vbCrlf & _
|
|
"pWeekdayname " & pWeekdayname & vbCrlf & _
|
|
"FromDate " & FromDate & vbCrlf & _
|
|
"pIncludeToday " & pIncludeToday & vbCrlf & _
|
|
"IncludeToday " & IncludeToday & vbCrlf & _
|
|
"pSkipTodayByTime " & pSkipTodayByTime & vbCrlf & vbCrlf & _
|
|
"CurrentDayOfWeek: " & CurrentDayOfWeek & vbCrlf & _
|
|
"CurrentDayNumber: " & CurrentDayNumber & vbCrlf & _
|
|
"",,"DEBUG - GetDateByWeekdayname - Parameter given:"
|
|
End If
|
|
|
|
CalcDate = FromDate
|
|
CalcDayNumber = CurrentDayNumber
|
|
Counter = 0
|
|
|
|
DO
|
|
|
|
'If pIncludeToday = False, skip the current FromDate and add one day
|
|
IF (IncludeToday = False) then
|
|
|
|
Counter = Counter + 1
|
|
CalcDayNumber = CalcDayNumber + 1
|
|
|
|
End If
|
|
|
|
'Reset day, but keep counter
|
|
IF (CalcDayNumber > 7) Then
|
|
CalcDayNumber = 1
|
|
end if
|
|
|
|
CalcDate = Dateadd("d", + counter, FromDate)
|
|
|
|
If (DEBUG_ON = True) Or (DebugMode = "Enabled") Then
|
|
MsgBox "pWeekdayname: " & pWeekdayname & vbCrlf & _
|
|
"pFromDate: " & pFromDate & vbCrlf & _
|
|
"pIncludeToday: " & pIncludeToday & vbCrlf & _
|
|
"pSkipTodayByTime: " & pSkipTodayByTime & vbCrlf & vbCrlf & _
|
|
"Counter: " & Counter & vbCrlf & _
|
|
"CalcDayNumber: " & CalcDayNumber & vbCrlf & _
|
|
"CalcWeekdayname: " & Weekdayname(CalcDayNumber,False,1) & vbCrlf & _
|
|
"CalcWeekday: " & Weekday(CalcDayNumber) & vbCrlf & _
|
|
"CalcDate: " & CalcDate,, "DEBUG - GetDateByWeekdayname - Loop " & Counter
|
|
End If
|
|
|
|
CalcDayOfWeek = Weekdayname(CalcDayNumber,False,1)
|
|
|
|
'Failsafe to prevent endless loops
|
|
IF ((CalcDayOfWeek = pWeekdayname) or (Counter = 31)) THEN EXIT DO
|
|
|
|
'If pIncludeToday = True, dont skip the current FromDate
|
|
IF (IncludeToday = True) then
|
|
|
|
Counter = Counter + 1
|
|
CalcDayNumber = CalcDayNumber + 1
|
|
|
|
End If
|
|
|
|
LOOP
|
|
|
|
If (DEBUG_ON = True) Or (DebugMode = "Enabled") Then
|
|
MsgBox "Errechnet: " & cdate(CalcDate),,"DEBUG - GetDateByWeekdayname - Ergebnis"
|
|
End if
|
|
|
|
Else
|
|
|
|
CalcDate = "01.01.1970"
|
|
|
|
If (DEBUG_ON = True) Or (DebugMode = "Enabled") Then
|
|
MsgBox "Ungültiges Datum, failsafe auf: 01.01.1970",,"DEBUG - GetDateByWeekdayname - Ergebnis"
|
|
End if
|
|
|
|
End if
|
|
|
|
'Return calculated date
|
|
GetDateByWeekdayname = cdate(CalcDate)
|
|
|
|
end function 'GetDateByWeekdayname
|
|
|
|
'datetest = GetDateByWeekdayname ("Dienstag","12.10.2021",false,"12:00")
|
|
'msgbox datetest |