modDateFunc.bas

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