Build a table of holidays - Revised 2

[GComyn]

in looking at faq705-6003, I tried to see what it would look like, so I copied it to my access database... it worked ok...

Then I went to see if there were any function on the net that would speed it up any... and I found a couple.

the Table 'tblHolidays' should already exist.
the fields are:
HolidayDate Date/Time
HolidayName Text
Weekday Text

Here is the code that I adapted from the faq:

Option Compare Database
Option Explicit

Const DBLQUOTE As String = """"

Public Type HolidayData
    dtDate As Date
    strName As String
    strWeekday As String
End Type

Dim vHolidayInfo(9) As HolidayData

Public Function BuildHolidayList(BuildYear As Long)
On Error GoTo HandleErr

    Dim lngDay As Long
    Dim intWeekday As Integer
    Dim intMondayCount As Integer
    Dim intThursdayCount As Integer
    Dim dtDate As Date
    Dim strSQL As String

    DoCmd.SetWarnings False
    DoCmd.Hourglass True

    ' Get New Year's Day Holiday
    ' 1/1 or following Monday
    dtDate = CDate("1/1/" & CStr(BuildYear))
    With vHolidayInfo(0)
        .dtDate = GetMondayFollowing(dtDate)
        .strName = "New Year's Day"
        .strWeekday = GetWeekday(.dtDate)
    End With
    
    ' Get MLK Holiday
    ' Third Monday in January
    With vHolidayInfo(1)
        .dtDate = NDow(CInt(BuildYear), 1, 3, 2) 'dtDate + lngDay + 14
        .strName = "Martin Luther King's Birthday"
        .strWeekday = GetWeekday(.dtDate)
    End With
    
    'President's Day
    ' Third Monday in February
    With vHolidayInfo(2)
        .dtDate = NDow(CInt(BuildYear), 2, 3, 2) '  dtDate + lngDay + 14
        .strName = "President's Day"
        .strWeekday = GetWeekday(.dtDate)
    End With
    
    'Memorial Day
    ' Last Monday in May
    With vHolidayInfo(3)
        .dtDate = NDow(CInt(BuildYear), 5, DOWsInMonth(CInt(BuildYear), 5, 2), 2) 'dtDate + lngDay
        .strName = "Memorial Day"
        .strWeekday = GetWeekday(.dtDate)
    End With
    
    'Independence Day
    '7/4 or following Monday
    dtDate = CDate("7/4/" & CStr(BuildYear))
    With vHolidayInfo(4)
        .dtDate = GetMondayFollowing(dtDate)
        .strName = "Independence Day"
        .strWeekday = GetWeekday(.dtDate)
    End With
    
    'Labor Day
    ' First Monday in September
    With vHolidayInfo(5)
        .dtDate = NDow(CInt(BuildYear), 9, 1, 2) 'dtDate + lngDay
        .strName = "Labor Day"
        .strWeekday = GetWeekday(.dtDate)
    End With
    
    'Columbus Day
    ' Second Monday In October
    With vHolidayInfo(6)
        .dtDate = NDow(CInt(BuildYear), 10, 2, 2)
        .strName = "Columbus Day"
        .strWeekday = GetWeekday(.dtDate)
    End With
    
    'Veterans Day
    '11/11 or following Monday
    With vHolidayInfo(7)
        .dtDate = GetMondayFollowing(CDate("11/11/" & CStr(BuildYear)))
        .strName = "Veterans Day"
        .strWeekday = GetWeekday(.dtDate)
    End With
    
    'Thanksgiving Day
    ' Fourth Thursday in November
    With vHolidayInfo(8)
        .dtDate = NDow(CInt(BuildYear), 11, 4, 5) 'dtDate + lngDay
        .strName = "Thanksgiving Day"
        .strWeekday = GetWeekday(.dtDate)
    End With
    'Day-After Thanksgiving
    'Fourth Thursday in November + 1 day
    'Removed from code as it is not used at my business, but left to show how it was done.
'    With vHolidayInfo(9)
'        .dtDate = ThanksgivingDate(CStr(BuildYear)) + 1  'dtDate + lngDay + 1
'        .strName = "Day-After Thanksgiving"
'        .strWeekday = GetWeekday(.dtDate)
'    End With
    
    'Christmas Day
    '12/25 or following Monday
    dtDate = CDate("12/25/" & CStr(BuildYear))
    With vHolidayInfo(9)
        .dtDate = GetMondayFollowing(dtDate)
        .strName = "Christmas Day"
        .strWeekday = GetWeekday(.dtDate)
    End With
    
    strSQL = "DELETE FROM tblHolidays WHERE YEAR(HolidayDate) IN (" & CLng(BuildYear) & ")"
    DoCmd.RunSQL strSQL
    
    For lngDay = 0 To UBound(vHolidayInfo)
        strSQL = "INSERT INTO tblHolidays (HolidayDate, HolidayName, Weekday) " & _
                 "SELECT cdate('" & CStr(vHolidayInfo(lngDay).dtDate) & "'), " & _
                 DBLQUOTE & vHolidayInfo(lngDay).strName & DBLQUOTE & ", " & _
                 DBLQUOTE & vHolidayInfo(lngDay).strWeekday & DBLQUOTE
        DoCmd.RunSQL strSQL
    Next lngDay
   
Exit_Proc:
    DoCmd.SetWarnings True
    DoCmd.Hourglass False
    Exit Function

HandleErr:
    Select Case Err.Number
    Case Else
        Call ErrorLog("basSchedule_BuildHolidayList", Err)
    End Select
    Resume Exit_Proc
    Resume
End Function

Public Function GetWeekday(dtDate As Date) As String

    Dim strWeekday As String
    Dim intWeekday As Integer
    intWeekday = Weekday(dtDate)

On Error GoTo HandleErr

    Select Case intWeekday
        Case vbMonday
            strWeekday = "Monday"
        Case vbTuesday
            strWeekday = "Tuesday"
        Case vbWednesday
            strWeekday = "Wednesday"
        Case vbThursday
            strWeekday = "Thursday"
        Case vbFriday
            strWeekday = "Friday"
        Case vbSaturday
            strWeekday = "Saturday"
        Case vbSunday
            strWeekday = "Sunday"
        Case Else
            strWeekday = "Unknown"
    End Select
    GetWeekday = strWeekday
   
Exit_Proc:
    Exit Function

HandleErr:
    Select Case Err.Number
    Case Else
        Call ErrorLog("basSchedule_GetWeekday", Err)
    End Select
    Resume Exit_Proc
    Resume
End Function

Public Function BuildHolidayLists(lngYears As Long)
    Dim x As Long
    Dim lngYear As Long
    
    lngYear = Year(Date)
    
    For x = 0 To lngYears - 1
        Call BuildHolidayList(lngYear + x)
    Next x
End Function

Public Function GetMondayFollowing(dtDate As Date) As Date
      
On Error GoTo HandleErr

      'vbSaturday = 7
      'vbSunday = 0
      Dim intDayOfWeek
      
      intDayOfWeek = Weekday(dtDate)
      Select Case intDayOfWeek
          Case vbMonday To vbFriday
              GetMondayFollowing = dtDate
          Case vbSaturday
              GetMondayFollowing = dtDate + 2
          Case vbSunday
              GetMondayFollowing = dtDate + 1
      End Select
     
Exit_Proc:
    Exit Function

HandleErr:
    Select Case Err.Number
    Case Else
        Call ErrorLog("basSchedule_GetMondayFollowing", Err)
    End Select
    Resume Exit_Proc
    Resume
End Function

Public Function NDow(Y As Integer, M As Integer, N As Integer, DOW As Integer) As Date
On Error GoTo HandleErr:
    NDow = DateSerial(Y, M, (8 - Weekday(DateSerial(Y, M, 1), (DOW + 1) Mod 8)) + ((N - 1) * 7))
    Exit Function

HandleErr:
    Select Case Err.Number
    Case Else
        Call ErrorLog("NDow", Err)
    End Select
    NDow = 0
End Function

Public Function DOWsInMonth(Yr As Integer, M As Integer, DOW As Integer) As Integer
On Error GoTo EndFunction
    Dim I As Integer
    Dim Lim As Integer
    
    Lim = Day(DateSerial(Yr, M + 1, 0))
    DOWsInMonth = 0
    
    For I = 1 To Lim
        If Weekday(DateSerial(Yr, M, I)) = DOW Then
            DOWsInMonth = DOWsInMonth + 1
        End If
    Next I
    Exit Function

EndFunction:
    Select Case Err.Number
    Case Else
        Call ErrorLog("DOWsInMonth", Err)
    End Select
    DOWsInMonth = 0
End Function

GComyn

 

[JohnMossSamford]

Hey GComyn,

Neat stuff! I appreciate your posting and have used the code.

One small item: my business rules included the day after Thanksgiving which you'd commented out since you didn't need it. The code you commented out called an undefined function, ThanksgivingDate:

    'Removed from code as it is not used at my business, but left to show how it was done.
'    With vHolidayInfo(9)
'        .dtDate = ThanksgivingDate(CStr(BuildYear)) + 1  'dtDate + lngDay + 1
'        .strName = "Day-After Thanksgiving"
'        .strWeekday = GetWeekday(.dtDate)
'    End With

I changed it slightly to make use of the fact Thanksgiving had just been calculated in vHolidayInfo(8)

    'Day-After Thanksgiving
    'Fourth Thursday in November + 1 day
    With vHolidayInfo(9)
        .dtDate = vHolidayInfo(8).dtDate + 1
        .strName = "Day-After Thanksgiving"
        .strWeekday = GetWeekday(.dtDate)
    End With

Again, thanks for sharing!

John Samford

 

[GComyn]

Ahh... thanks for that.... I actually didn't use the ThanksgivingDate function at all... changing it to 'NDow(CInt(BuildYear), 11, 4, 5)'

And your change is even faster, because there isn't a function call... just a call to the array.

Thanks, and I'm going to implement that (even though I don't use it)

GComyn

 

[sparkbyte]

What function are you using for your errorlog?

HandleErr:
    Select Case Err.Number
    Case Else
        [highlight]Call ErrorLog("basSchedule_GetMondayFollowing", Err)[/highlight]
    End Select
    Resume Exit_Proc
    Resume
End Function

Thanks

John Fuhrman

 

[GComyn]

sorry about that. It was in my referenced library. here is the code for the error logging function

 Public Function ErrorLog(objName As String, routineName As String)
 Dim db As Database

 Set db = CurrentDb

 Open "C:\Error.log" For Append As #1

 Print #1, Format(Now, "mm/dd/yyyy, hh:nn:ss") & ", " & db.Name & _
     "An error occured in " & objName & ", " & routineName & _
     ", " & CurrentUser() & ", Error#: " & Err.Number & ", " & Err.Description

 Close #1
 End Function