daily pastebin goal
42%
SHARE
TWEET

modDateFunc.bas

PikaNikz Feb 10th, 2012 74 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Attribute VB_Name = "modDateFunc"
  2. 'by JA
  3.  
  4. 'National Holidays - As Observed by the U.S. Government
  5. '   New Years           Month = 1 : Date = 1
  6. '   Independence Day    Month = 7 : Date = 4
  7. '   XMas                Month = 12 : Date = 25
  8. '   Easter              Sunday following the Paschal Full Moon
  9. '   Thanksgiving        Month = 11 : Third Thursday
  10. '   Memorial Day        Month = 5 : Third Monday
  11.  
  12. Option Explicit
  13.  
  14. 'Adds intDays to date given compensating for weekends and national holidays
  15. Public Function GetBusinessDayDiff(strDate As String, _
  16.                                    intDays As Integer, _
  17.                                    Optional strMsgBoxTitle As String, _
  18.                                    Optional blnErr_ShowFriendly As Boolean, _
  19.                                    Optional blnErr_ShowCritical As Boolean _
  20.                                   ) As String
  21. On Error GoTo err_GetBusinessDayDiff    'initiate error handler
  22.    GetBusinessDayDiff = vbNullString    'set default return
  23.    
  24.     GetBusinessDayDiff = GetNextBusinessDay(DateAdd("d", intDays, strDate))
  25.    
  26. Exit Function
  27. err_GetBusinessDayDiff:    'error handler
  28.    GetBusinessDayDiff = vbNullString    'set internal error return
  29.    'send message to immediate window
  30.    Debug.Print Now & " | Function: GetBusinessDayDiff | Error: #" & _
  31.                 Err.Number & vbTab & Err.Description
  32.     'if we want to show critical messages to the user
  33.    If blnErr_ShowCritical = True Then
  34.         'notify the user
  35.        MsgBox "Error: #" & Err.Number & vbTab & Err.Description & _
  36.                vbCrLf & vbCrLf & Now, _
  37.                vbOKOnly + vbCritical, _
  38.                strMsgBoxTitle & " [Function: GetBusinessDayDiff - " & Err.Source & "]"
  39.     End If
  40.     Err.Clear    'clear the error object
  41. On Error Resume Next
  42.     'Cleanup
  43.    
  44. End Function
  45.  
  46. 'Compensates for weekends and national holidays
  47. Public Function GetNextBusinessDay(strDate As String, _
  48.                                    Optional strMsgBoxTitle As String, _
  49.                                    Optional blnErr_ShowFriendly As Boolean, _
  50.                                    Optional blnErr_ShowCritical As Boolean _
  51.                                   ) As String
  52. On Error GoTo err_GetNextBusinessDay    'initiate error handler
  53.    GetNextBusinessDay = vbNullString    'set default return
  54.    
  55.     Dim blnHoliday      As Boolean
  56.     Dim blnWeekend      As Boolean
  57.    
  58.     strDate = Format(strDate, "m/d/yyyy")
  59.    
  60.     blnHoliday = IsHoliday(strDate)
  61.     blnWeekend = IsWeekend(strDate)
  62.    
  63.     Do Until blnHoliday = False And blnWeekend = False
  64.         If blnHoliday = True Or blnWeekend = True Then
  65.             strDate = DateAdd("d", 1, strDate)
  66.         End If
  67.         blnHoliday = IsHoliday(strDate)
  68.         blnWeekend = IsWeekend(strDate)
  69.     Loop
  70.    
  71.     GetNextBusinessDay = Format(strDate, "mm/dd/yyyy")
  72.    
  73. Exit Function
  74. err_GetNextBusinessDay:    'error handler
  75.    GetNextBusinessDay = vbNullString    'set internal error return
  76.    'send message to immediate window
  77.    Debug.Print Now & " | Function: GetNextBusinessDay | Error: #" & _
  78.                 Err.Number & vbTab & Err.Description
  79.     'if we want to show critical messages to the user
  80.    If blnErr_ShowCritical = True Then
  81.         'notify the user
  82.        MsgBox "Error: #" & Err.Number & vbTab & Err.Description & _
  83.                vbCrLf & vbCrLf & Now, _
  84.                vbOKOnly + vbCritical, _
  85.                strMsgBoxTitle & " [Function: GetNextBusinessDay - " & Err.Source & "]"
  86.     End If
  87.     Err.Clear    'clear the error object
  88. On Error Resume Next
  89.     'Cleanup
  90.    
  91. End Function
  92.  
  93. 'EASTER DATE CALCULATION FOR YEARS 1583 TO 4099
  94. 'Easter Sunday is the Sunday following the Paschal Full Moon (PFM) date for the year
  95. 'This algorithm is an arithmetic interpretation of the 3 step Easter Dating Method developed
  96. ' by Ron Mallen 1985, as a vast improvement on the method described in the Common Prayer Book
  97. 'Because this algorithm is a direct translation of the official tables, it can be easily proved to be 100% correct
  98. 'This algorithm derives values by sequential inter-dependent calculations
  99. 'The \ operator may be unfamiliar - it means integer division : for example, 30 \ 7 = 4 (the remainder is ignored)
  100. Public Function IsEaster(strDate As String, _
  101.                          Optional strMsgBoxTitle As String, _
  102.                          Optional blnErr_ShowFriendly As Boolean, _
  103.                          Optional blnErr_ShowCritical As Boolean _
  104.                         ) As Boolean
  105. On Error GoTo err_IsEaster    'initiate error handler
  106.    
  107.     'date results
  108.    Dim intYear             As Integer
  109.     Dim intMonth            As Integer
  110.     Dim intDay              As Integer
  111.    
  112.     'intermediate results
  113.    Dim intFirstDig         As Integer
  114.     Dim intRemain19         As Integer
  115.     Dim intTemp             As Integer
  116.    
  117.     'table A To E results
  118.    Dim intTBL_A            As Integer
  119.     Dim intTBL_B            As Integer
  120.     Dim intTBL_C            As Integer
  121.     Dim intTBL_D            As Integer
  122.     Dim intTBL_E            As Integer
  123.    
  124.     strDate = Format(strDate, "m/d/yyyy")
  125.     intYear = Right(strDate, 4)
  126.    
  127.     intFirstDig = intYear \ 100     'first 2 digits of year
  128.    intRemain19 = intYear Mod 19    'remainder of year / 19
  129.    
  130.     'calculate PFM date
  131.    intTemp = (intFirstDig - 15) \ 2 + 202 - 11 * intRemain19
  132.     If intFirstDig > 26 Then intTemp = intTemp - 1
  133.     If intFirstDig > 38 Then intTemp = intTemp - 1
  134.    
  135.     Select Case intFirstDig
  136.         Case 21, 24, 25, 33, 36, 37: intTemp = intTemp - 1
  137.     End Select
  138.    
  139.     intTemp = intTemp Mod 30
  140.     intTBL_A = intTemp + 21
  141.     If intTemp = 29 Then intTBL_A = intTBL_A - 1
  142.    
  143.     'find the next Sunday
  144.    If (intTemp = 28 And intRemain19 > 10) Then intTBL_A = intTBL_A - 1
  145.     intTBL_B = (intTBL_A - 19) Mod 7
  146.     intTBL_C = (40 - intFirstDig) Mod 4
  147.    
  148.     If intTBL_C = 3 Then intTBL_C = intTBL_C + 1
  149.     If intTBL_C > 1 Then intTBL_C = intTBL_C + 1
  150.    
  151.     intTemp = intYear Mod 100
  152.    
  153.     intTBL_D = (intTemp + intTemp \ 4) Mod 7
  154.     intTBL_E = ((20 - intTBL_B - intTBL_C - intTBL_D) Mod 7) + 1
  155.    
  156.     intDay = intTBL_A + intTBL_E
  157.    
  158.     'complete the date
  159.    If intDay > 31 Then
  160.         intDay = intDay - 31
  161.         intMonth = 4
  162.     Else
  163.         intMonth = 3
  164.     End If
  165.    
  166.     If intMonth & "/" & intDay & "/" & intYear = strDate Then IsEaster = True
  167.    
  168.     Exit Function
  169. err_IsEaster:    'error handler
  170.    IsEaster = False     'set internal error return
  171.    'send message to immediate window
  172.    Debug.Print Now & " | Function: & IsEaster & | Error: #" & _
  173.                 Err.Number & vbTab & Err.Description
  174.     'if we want to show critical messages to the user
  175.    If blnErr_ShowCritical = True Then
  176.         'notify the user
  177.        Select Case MsgBox("Error: #" & Err.Number & vbTab & Err.Description & _
  178.                            vbCrLf & vbCrLf & Now, _
  179.                            vbAbortRetryIgnore + vbCritical, _
  180.                            strMsgBoxTitle & " [Function: IsEaster]")
  181.             Case vbAbort:     Exit Function
  182.             Case vbRetry:     Resume
  183.             Case vbIgnore:    Resume Next
  184.         End Select
  185.     End If
  186.     Err.Clear    'clear the error object
  187. On Error Resume Next
  188.     'Cleanup
  189.    
  190. End Function
  191.  
  192. Public Function IsHoliday(strDate As String, _
  193.                           Optional strMsgBoxTitle As String, _
  194.                           Optional blnErr_ShowFriendly As Boolean, _
  195.                           Optional blnErr_ShowCritical As Boolean _
  196.                          ) As Boolean
  197. On Error GoTo err_IsHoliday    'initiate error handler
  198.    
  199.     strDate = Format(strDate, "m/d/yyyy")
  200.    
  201.     Select Case strDate
  202.         Case "1/1/" & Right(strDate, 4):    IsHoliday = True    'New Years
  203.        Case "7/4/" & Right(strDate, 4):    IsHoliday = True    'Independence Day
  204.        Case "12/25/" & Right(strDate, 4):  IsHoliday = True    'XMas
  205.    End Select
  206.    
  207.     If IsEaster(strDate) = 1 Then IsHoliday = True
  208.     If IsThanksgiving(strDate) = True Then IsHoliday = True
  209.     If IsMemorialDay(strDate) = True Then IsHoliday = True
  210.    
  211. Exit Function
  212. err_IsHoliday:    'error handler
  213.    IsHoliday = False    'set internal error return
  214.    'send message to immediate window
  215.    Debug.Print Now & " | Function: IsHoliday | Error: #" & _
  216.                 Err.Number & vbTab & Err.Description
  217.     'if we want to show critical messages to the user
  218.    If blnErr_ShowCritical = True Then
  219.         'notify the user
  220.        MsgBox "Error: #" & Err.Number & vbTab & Err.Description & _
  221.                vbCrLf & vbCrLf & Now, _
  222.                vbOKOnly + vbCritical, _
  223.                strMsgBoxTitle & " [Function: IsHoliday - " & Err.Source & "]"
  224.     End If
  225.     Err.Clear    'clear the error object
  226. On Error Resume Next
  227.     'Cleanup
  228.    
  229. End Function
  230.  
  231. Public Function IsMemorialDay(strDate As String, _
  232.                               Optional strMsgBoxTitle As String, _
  233.                               Optional blnErr_ShowFriendly As Boolean, _
  234.                               Optional blnErr_ShowCritical As Boolean _
  235.                              ) As Boolean
  236. On Error GoTo err_IsMemorialDay    'initiate error handler
  237.    
  238.     Dim intNumMondays           As Integer
  239.     Dim lngIndex                As Long
  240.     Dim intMemorialDate         As Integer
  241.    
  242.     strDate = Format(strDate, "m/d/yyyy")
  243.    
  244.     For lngIndex = 1 To 30
  245.         If Weekday("5/" & lngIndex & "/" & Right(strDate, 4)) = vbMonday Then
  246.             If intNumMondays = 3 Then
  247.                 intMemorialDate = lngIndex
  248.                 Exit For
  249.             Else
  250.                 intNumMondays = intNumMondays + 1
  251.             End If
  252.         End If
  253.     Next lngIndex
  254.    
  255.     If strDate = "5/" & intMemorialDate & "/" & Right(strDate, 4) Then IsMemorialDay = True
  256.    
  257.     Exit Function
  258. err_IsMemorialDay:    'error handler
  259.    IsMemorialDay = -1    'set internal error return
  260.    'send message to immediate window
  261.    Debug.Print Now & " | Function: & IsMemorialDay & | Error: #" & _
  262.                 Err.Number & vbTab & Err.Description
  263.     'if we want to show critical messages to the user
  264.    If blnErr_ShowCritical = True Then
  265.         'notify the user
  266.        Select Case MsgBox("Error: #" & Err.Number & vbTab & Err.Description & _
  267.                            vbCrLf & vbCrLf & Now, _
  268.                            vbAbortRetryIgnore + vbCritical, _
  269.                            strMsgBoxTitle & " [Function: IsMemorialDay" & "]")
  270.             Case vbAbort:     Exit Function
  271.             Case vbRetry:     Resume
  272.             Case vbIgnore:    Resume Next
  273.         End Select
  274.     End If
  275.     Err.Clear    'clear the error object
  276. On Error Resume Next
  277.     'Cleanup
  278.    
  279. End Function
  280.  
  281. Public Function IsThanksgiving(strDate As String, _
  282.                                Optional strMsgBoxTitle As String, _
  283.                                Optional blnErr_ShowFriendly As Boolean, _
  284.                                Optional blnErr_ShowCritical As Boolean _
  285.                                ) As Boolean
  286. On Error GoTo err_IsThanksgiving    'initiate error handler
  287.    
  288.     Dim intNumThursdays             As Integer
  289.     Dim lngIndex                    As Long
  290.     Dim intThanksGivingDate         As Integer
  291.    
  292.     strDate = Format(strDate, "m/d/yyyy")
  293.    
  294.     For lngIndex = 1 To 30
  295.         If Weekday("11/" & lngIndex & "/" & Right(strDate, 4)) = vbThursday Then
  296.             If intNumThursdays = 3 Then
  297.                 intThanksGivingDate = lngIndex
  298.                 Exit For
  299.             Else
  300.                 intNumThursdays = intNumThursdays + 1
  301.             End If
  302.         End If
  303.     Next lngIndex
  304.    
  305.     If strDate = "11/" & intThanksGivingDate & "/" & Right(strDate, 4) Then IsThanksgiving = True
  306.    
  307.     Exit Function
  308. err_IsThanksgiving:    'error handler
  309.    IsThanksgiving = False     'set internal error return
  310.    'send message to immediate window
  311.    Debug.Print Now & " | Function: & IsThanksgiving & | Error: #" & _
  312.                 Err.Number & vbTab & Err.Description
  313.     'if we want to show critical messages to the user
  314.    If blnErr_ShowCritical = True Then
  315.         'notify the user
  316.        Select Case MsgBox("Error: #" & Err.Number & vbTab & Err.Description & _
  317.                            vbCrLf & vbCrLf & Now, _
  318.                            vbAbortRetryIgnore + vbCritical, _
  319.                            strMsgBoxTitle & " [Function: IsThanksgiving" & "]")
  320.             Case vbAbort:     Exit Function
  321.             Case vbRetry:     Resume
  322.             Case vbIgnore:    Resume Next
  323.         End Select
  324.     End If
  325.     Err.Clear    'clear the error object
  326. On Error Resume Next
  327.     'Cleanup
  328.    
  329. End Function
  330.  
  331. Public Function IsWeekend(strDate As String, _
  332.                           Optional strMsgBoxTitle As String, _
  333.                           Optional blnErr_ShowFriendly As Boolean, _
  334.                           Optional blnErr_ShowCritical As Boolean _
  335.                          ) As Boolean
  336. On Error GoTo err_IsWeekend    'initiate error handler
  337.    IsWeekend = False
  338.    
  339.     strDate = Format(strDate, "m/d/yyyy")
  340.    
  341.     Select Case Weekday(strDate)
  342.         Case 1, 7:  IsWeekend = True
  343.     End Select
  344.    
  345. Exit Function
  346. err_IsWeekend:    'error handler
  347.    IsWeekend = False    'set internal error return
  348.    'send message to immediate window
  349.    Debug.Print Now & " | Function: IsWeekend | Error: #" & _
  350.                 Err.Number & vbTab & Err.Description
  351.     'if we want to show critical messages to the user
  352.    If blnErr_ShowCritical = True Then
  353.         'notify the user
  354.        MsgBox "Error: #" & Err.Number & vbTab & Err.Description & _
  355.                vbCrLf & vbCrLf & Now, _
  356.                vbOKOnly + vbCritical, _
  357.                strMsgBoxTitle & " [Function: IsWeekend - " & Err.Source & "]"
  358.     End If
  359.     Err.Clear    'clear the error object
  360. On Error Resume Next
  361.     'Cleanup
  362.    
  363. End Function
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top