Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- Attribute VB_Name = "modDateFunc"
- 'by JA
- 'National Holidays - As Observed by the U.S. Government
- ' New Years Month = 1 : Date = 1
- ' Independence Day Month = 7 : Date = 4
- ' XMas Month = 12 : Date = 25
- ' Easter Sunday following the Paschal Full Moon
- ' Thanksgiving Month = 11 : Third Thursday
- ' Memorial Day Month = 5 : Third Monday
- Option Explicit
- 'Adds intDays to date given compensating for weekends and national holidays
- Public Function GetBusinessDayDiff(strDate As String, _
- intDays As Integer, _
- Optional strMsgBoxTitle As String, _
- Optional blnErr_ShowFriendly As Boolean, _
- Optional blnErr_ShowCritical As Boolean _
- ) As String
- On Error GoTo err_GetBusinessDayDiff 'initiate error handler
- GetBusinessDayDiff = vbNullString 'set default return
- GetBusinessDayDiff = GetNextBusinessDay(DateAdd("d", intDays, strDate))
- Exit Function
- err_GetBusinessDayDiff: 'error handler
- GetBusinessDayDiff = vbNullString 'set internal error return
- 'send message to immediate window
- Debug.Print Now & " | Function: GetBusinessDayDiff | Error: #" & _
- Err.Number & vbTab & Err.Description
- 'if we want to show critical messages to the user
- If blnErr_ShowCritical = True Then
- 'notify the user
- MsgBox "Error: #" & Err.Number & vbTab & Err.Description & _
- vbCrLf & vbCrLf & Now, _
- vbOKOnly + vbCritical, _
- strMsgBoxTitle & " [Function: GetBusinessDayDiff - " & Err.Source & "]"
- End If
- Err.Clear 'clear the error object
- On Error Resume Next
- 'Cleanup
- End Function
- 'Compensates for weekends and national holidays
- Public Function GetNextBusinessDay(strDate As String, _
- Optional strMsgBoxTitle As String, _
- Optional blnErr_ShowFriendly As Boolean, _
- Optional blnErr_ShowCritical As Boolean _
- ) As String
- On Error GoTo err_GetNextBusinessDay 'initiate error handler
- GetNextBusinessDay = vbNullString 'set default return
- Dim blnHoliday As Boolean
- Dim blnWeekend As Boolean
- strDate = Format(strDate, "m/d/yyyy")
- blnHoliday = IsHoliday(strDate)
- blnWeekend = IsWeekend(strDate)
- Do Until blnHoliday = False And blnWeekend = False
- If blnHoliday = True Or blnWeekend = True Then
- strDate = DateAdd("d", 1, strDate)
- End If
- blnHoliday = IsHoliday(strDate)
- blnWeekend = IsWeekend(strDate)
- Loop
- GetNextBusinessDay = Format(strDate, "mm/dd/yyyy")
- Exit Function
- err_GetNextBusinessDay: 'error handler
- GetNextBusinessDay = vbNullString 'set internal error return
- 'send message to immediate window
- Debug.Print Now & " | Function: GetNextBusinessDay | Error: #" & _
- Err.Number & vbTab & Err.Description
- 'if we want to show critical messages to the user
- If blnErr_ShowCritical = True Then
- 'notify the user
- MsgBox "Error: #" & Err.Number & vbTab & Err.Description & _
- vbCrLf & vbCrLf & Now, _
- vbOKOnly + vbCritical, _
- strMsgBoxTitle & " [Function: GetNextBusinessDay - " & Err.Source & "]"
- End If
- Err.Clear 'clear the error object
- On Error Resume Next
- 'Cleanup
- End Function
- 'EASTER DATE CALCULATION FOR YEARS 1583 TO 4099
- 'Easter Sunday is the Sunday following the Paschal Full Moon (PFM) date for the year
- 'This algorithm is an arithmetic interpretation of the 3 step Easter Dating Method developed
- ' by Ron Mallen 1985, as a vast improvement on the method described in the Common Prayer Book
- 'Because this algorithm is a direct translation of the official tables, it can be easily proved to be 100% correct
- 'This algorithm derives values by sequential inter-dependent calculations
- 'The \ operator may be unfamiliar - it means integer division : for example, 30 \ 7 = 4 (the remainder is ignored)
- Public Function IsEaster(strDate As String, _
- Optional strMsgBoxTitle As String, _
- Optional blnErr_ShowFriendly As Boolean, _
- Optional blnErr_ShowCritical As Boolean _
- ) As Boolean
- On Error GoTo err_IsEaster 'initiate error handler
- 'date results
- Dim intYear As Integer
- Dim intMonth As Integer
- Dim intDay As Integer
- 'intermediate results
- Dim intFirstDig As Integer
- Dim intRemain19 As Integer
- Dim intTemp As Integer
- 'table A To E results
- Dim intTBL_A As Integer
- Dim intTBL_B As Integer
- Dim intTBL_C As Integer
- Dim intTBL_D As Integer
- Dim intTBL_E As Integer
- strDate = Format(strDate, "m/d/yyyy")
- intYear = Right(strDate, 4)
- intFirstDig = intYear \ 100 'first 2 digits of year
- intRemain19 = intYear Mod 19 'remainder of year / 19
- 'calculate PFM date
- intTemp = (intFirstDig - 15) \ 2 + 202 - 11 * intRemain19
- If intFirstDig > 26 Then intTemp = intTemp - 1
- If intFirstDig > 38 Then intTemp = intTemp - 1
- Select Case intFirstDig
- Case 21, 24, 25, 33, 36, 37: intTemp = intTemp - 1
- End Select
- intTemp = intTemp Mod 30
- intTBL_A = intTemp + 21
- If intTemp = 29 Then intTBL_A = intTBL_A - 1
- 'find the next Sunday
- If (intTemp = 28 And intRemain19 > 10) Then intTBL_A = intTBL_A - 1
- intTBL_B = (intTBL_A - 19) Mod 7
- intTBL_C = (40 - intFirstDig) Mod 4
- If intTBL_C = 3 Then intTBL_C = intTBL_C + 1
- If intTBL_C > 1 Then intTBL_C = intTBL_C + 1
- intTemp = intYear Mod 100
- intTBL_D = (intTemp + intTemp \ 4) Mod 7
- intTBL_E = ((20 - intTBL_B - intTBL_C - intTBL_D) Mod 7) + 1
- intDay = intTBL_A + intTBL_E
- 'complete the date
- If intDay > 31 Then
- intDay = intDay - 31
- intMonth = 4
- Else
- intMonth = 3
- End If
- If intMonth & "/" & intDay & "/" & intYear = strDate Then IsEaster = True
- Exit Function
- err_IsEaster: 'error handler
- IsEaster = False 'set internal error return
- 'send message to immediate window
- Debug.Print Now & " | Function: & IsEaster & | Error: #" & _
- Err.Number & vbTab & Err.Description
- 'if we want to show critical messages to the user
- If blnErr_ShowCritical = True Then
- 'notify the user
- Select Case MsgBox("Error: #" & Err.Number & vbTab & Err.Description & _
- vbCrLf & vbCrLf & Now, _
- vbAbortRetryIgnore + vbCritical, _
- strMsgBoxTitle & " [Function: IsEaster]")
- Case vbAbort: Exit Function
- Case vbRetry: Resume
- Case vbIgnore: Resume Next
- End Select
- End If
- Err.Clear 'clear the error object
- On Error Resume Next
- 'Cleanup
- End Function
- Public Function IsHoliday(strDate As String, _
- Optional strMsgBoxTitle As String, _
- Optional blnErr_ShowFriendly As Boolean, _
- Optional blnErr_ShowCritical As Boolean _
- ) As Boolean
- On Error GoTo err_IsHoliday 'initiate error handler
- strDate = Format(strDate, "m/d/yyyy")
- Select Case strDate
- Case "1/1/" & Right(strDate, 4): IsHoliday = True 'New Years
- Case "7/4/" & Right(strDate, 4): IsHoliday = True 'Independence Day
- Case "12/25/" & Right(strDate, 4): IsHoliday = True 'XMas
- End Select
- If IsEaster(strDate) = 1 Then IsHoliday = True
- If IsThanksgiving(strDate) = True Then IsHoliday = True
- If IsMemorialDay(strDate) = True Then IsHoliday = True
- Exit Function
- err_IsHoliday: 'error handler
- IsHoliday = False 'set internal error return
- 'send message to immediate window
- Debug.Print Now & " | Function: IsHoliday | Error: #" & _
- Err.Number & vbTab & Err.Description
- 'if we want to show critical messages to the user
- If blnErr_ShowCritical = True Then
- 'notify the user
- MsgBox "Error: #" & Err.Number & vbTab & Err.Description & _
- vbCrLf & vbCrLf & Now, _
- vbOKOnly + vbCritical, _
- strMsgBoxTitle & " [Function: IsHoliday - " & Err.Source & "]"
- End If
- Err.Clear 'clear the error object
- On Error Resume Next
- 'Cleanup
- End Function
- Public Function IsMemorialDay(strDate As String, _
- Optional strMsgBoxTitle As String, _
- Optional blnErr_ShowFriendly As Boolean, _
- Optional blnErr_ShowCritical As Boolean _
- ) As Boolean
- On Error GoTo err_IsMemorialDay 'initiate error handler
- Dim intNumMondays As Integer
- Dim lngIndex As Long
- Dim intMemorialDate As Integer
- strDate = Format(strDate, "m/d/yyyy")
- For lngIndex = 1 To 30
- If Weekday("5/" & lngIndex & "/" & Right(strDate, 4)) = vbMonday Then
- If intNumMondays = 3 Then
- intMemorialDate = lngIndex
- Exit For
- Else
- intNumMondays = intNumMondays + 1
- End If
- End If
- Next lngIndex
- If strDate = "5/" & intMemorialDate & "/" & Right(strDate, 4) Then IsMemorialDay = True
- Exit Function
- err_IsMemorialDay: 'error handler
- IsMemorialDay = -1 'set internal error return
- 'send message to immediate window
- Debug.Print Now & " | Function: & IsMemorialDay & | Error: #" & _
- Err.Number & vbTab & Err.Description
- 'if we want to show critical messages to the user
- If blnErr_ShowCritical = True Then
- 'notify the user
- Select Case MsgBox("Error: #" & Err.Number & vbTab & Err.Description & _
- vbCrLf & vbCrLf & Now, _
- vbAbortRetryIgnore + vbCritical, _
- strMsgBoxTitle & " [Function: IsMemorialDay" & "]")
- Case vbAbort: Exit Function
- Case vbRetry: Resume
- Case vbIgnore: Resume Next
- End Select
- End If
- Err.Clear 'clear the error object
- On Error Resume Next
- 'Cleanup
- End Function
- Public Function IsThanksgiving(strDate As String, _
- Optional strMsgBoxTitle As String, _
- Optional blnErr_ShowFriendly As Boolean, _
- Optional blnErr_ShowCritical As Boolean _
- ) As Boolean
- On Error GoTo err_IsThanksgiving 'initiate error handler
- Dim intNumThursdays As Integer
- Dim lngIndex As Long
- Dim intThanksGivingDate As Integer
- strDate = Format(strDate, "m/d/yyyy")
- For lngIndex = 1 To 30
- If Weekday("11/" & lngIndex & "/" & Right(strDate, 4)) = vbThursday Then
- If intNumThursdays = 3 Then
- intThanksGivingDate = lngIndex
- Exit For
- Else
- intNumThursdays = intNumThursdays + 1
- End If
- End If
- Next lngIndex
- If strDate = "11/" & intThanksGivingDate & "/" & Right(strDate, 4) Then IsThanksgiving = True
- Exit Function
- err_IsThanksgiving: 'error handler
- IsThanksgiving = False 'set internal error return
- 'send message to immediate window
- Debug.Print Now & " | Function: & IsThanksgiving & | Error: #" & _
- Err.Number & vbTab & Err.Description
- 'if we want to show critical messages to the user
- If blnErr_ShowCritical = True Then
- 'notify the user
- Select Case MsgBox("Error: #" & Err.Number & vbTab & Err.Description & _
- vbCrLf & vbCrLf & Now, _
- vbAbortRetryIgnore + vbCritical, _
- strMsgBoxTitle & " [Function: IsThanksgiving" & "]")
- Case vbAbort: Exit Function
- Case vbRetry: Resume
- Case vbIgnore: Resume Next
- End Select
- End If
- Err.Clear 'clear the error object
- On Error Resume Next
- 'Cleanup
- End Function
- Public Function IsWeekend(strDate As String, _
- Optional strMsgBoxTitle As String, _
- Optional blnErr_ShowFriendly As Boolean, _
- Optional blnErr_ShowCritical As Boolean _
- ) As Boolean
- On Error GoTo err_IsWeekend 'initiate error handler
- IsWeekend = False
- strDate = Format(strDate, "m/d/yyyy")
- Select Case Weekday(strDate)
- Case 1, 7: IsWeekend = True
- End Select
- Exit Function
- err_IsWeekend: 'error handler
- IsWeekend = False 'set internal error return
- 'send message to immediate window
- Debug.Print Now & " | Function: IsWeekend | Error: #" & _
- Err.Number & vbTab & Err.Description
- 'if we want to show critical messages to the user
- If blnErr_ShowCritical = True Then
- 'notify the user
- MsgBox "Error: #" & Err.Number & vbTab & Err.Description & _
- vbCrLf & vbCrLf & Now, _
- vbOKOnly + vbCritical, _
- strMsgBoxTitle & " [Function: IsWeekend - " & Err.Source & "]"
- End If
- Err.Clear 'clear the error object
- On Error Resume Next
- 'Cleanup
- End Function
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement