This piece of code was written -- just as a starting point -- to perhaps, at some point, add holidays to your server's holiday list. This code is for the U.S. only.
Option Public
Option Declare
Public Type Holiday
Name As String
Date As Variant
End Type
Sub Initialize
'See: http://www.vpcalendar.net/Holiday_Dates/Holiday_Determinations.html
Dim holidays(17) As Holiday
Dim tmpString As String
Dim tmpDate As Variant
Dim wkDay As Integer
Dim holidayYear As Integer
tmpString = Inputbox$("Enter year for
list of USA holidays dates for
that year")
On Error Goto errHandler
holidayYear = Cint(tmpString)
tmpString = ""
'===================================
holidays(0).Name = "New Year's Day"
'January 1 - Always
tmpDate = Dateserial(holidayYear, 1, 1)
holidays(0).Date = tmpDate
'===================================
'===================================
holidays(1).Name = "Martin Luther King Jr Day"
'3rd Monday in January - this means it can fall
anywhere between Jan.
15 and Jan. 21
tmpDate = Dateserial(holidayYear, 1, 15)
wkDay = Weekday(tmpDate)
holidays(1).Date = tmpDate - wkDay +
2 'Subtract the current day, add 2
for Monday
If wkDay > 2 Then
holidays(1).Date = holidays(1).Date + 7
'Add 7 to go to next
week
End If
'===================================
'===================================
holidays(2).Name = "Groundhog Day"
'February 1 - Always
tmpDate = Dateserial(holidayYear, 2, 2)
holidays(2).Date = tmpDate
'===================================
'===================================
holidays(3).Name = "Valentine's Day"
'February 14 - Always
tmpDate = Dateserial(holidayYear, 2, 14)
holidays(3).Date = tmpDate
'===================================
'===================================
holidays(4).Name = "President's Day"
'3rd Monday in February - this means it can
fall anywhere between Feb.
15 and Feb. 21
tmpDate = Dateserial(holidayYear, 2, 15)
wkDay = Weekday(tmpDate)
holidays(4).Date = tmpDate - wkDay + 2
'Subtract the current day, add 2
for Monday
If wkDay > 2 Then
holidays(4).Date = holidays(4).Date + 7
'Add 7 to go to next
week
End If
'===================================
'===================================
holidays(5).Name = "St. Patrick's Day"
'March 17 - Always
tmpDate = Dateserial(holidayYear, 3, 17)
holidays(5).Date = tmpDate
'===================================
'===================================
holidays(7).Name = "Easter"
holidays(7).Date = dateEaster(holidayYear)
'===================================
'===================================
holidays(6).Name = "Good Friday"
holidays(6).Date = holidays(7).Date - 2
'Easter Sunday - 2 days for
Good Friday
'===================================
'===================================
holidays(8).Name = "Mother's Day"
'2nd Sunday in May - this means it can fall
anywhere between May 8 and
May 14
tmpDate = Dateserial(holidayYear, 5, 8)
wkDay = Weekday(tmpDate)
holidays(8).Date = tmpDate - wkDay + 1
'Subtract the current day, add 1
for Sunday
If wkDay > 1 Then
holidays(8).Date = holidays(8).Date + 7
'Add 7 to go to next
week
End If
'===================================
'===================================
holidays(9).Name = "Memorial Day"
'Last Monday in May - this means it can fall
anywhere between May 25
and May 31
tmpDate = Dateserial(holidayYear, 5, 25)
wkDay = Weekday(tmpDate)
holidays(9).Date = tmpDate - wkDay + 2
'Subtract the current day, add 2
for Monday
If wkDay > 2 Then
holidays(9).Date = holidays(9).Date + 7
'Add 7 to go to next
week
End If
'===================================
'===================================
holidays(10).Name = "Father's Day"
'3rd Sunday in June - this means it can fall
anywhere between June 15
and June 21
tmpDate = Dateserial(holidayYear, 6, 15)
wkDay = Weekday(tmpDate)
holidays(10).Date = tmpDate - wkDay + 1
'Subtract the current day, add
1 for Sunday
If wkDay > 1 Then
holidays(10).Date = holidays(10).Date + 7
'Add 7 to go to next
week
End If
'===================================
'===================================
holidays(11).Name = "Independence Day"
'July 4 - Always
tmpDate = Dateserial(holidayYear, 7, 4)
holidays(11).Date = tmpDate
'===================================
'===================================
holidays(12).Name = "Labor Day"
'1st Monday in September - this means it can
fall anywhere between
Sept. 1 and Sept. 7
tmpDate = Dateserial(holidayYear, 9, 1)
wkDay = Weekday(tmpDate)
holidays(12).Date = tmpDate - wkDay + 2
'Subtract the current day, add
2 for Monday
If wkDay > 2 Then
holidays(12).Date = holidays(12).Date + 7
'Add 7 to go to next
week
End If
'===================================
'===================================
holidays(13).Name = "Columbus Day"
'2nd Monday in October - this means it can
fall anywhere between Oct. 8
and Oct. 14
tmpDate = Dateserial(holidayYear, 10, 8)
wkDay = Weekday(tmpDate)
holidays(13).Date = tmpDate - wkDay + 2
'Subtract the current day, add
2 for Monday
If wkDay > 2 Then
holidays(13).Date = holidays(13).Date + 7
'Add 7 to go to next
week
End If
'===================================
'===================================
holidays(14).Name = "Halloween"
'October 31 - Always
tmpDate = Dateserial(holidayYear, 10, 31)
holidays(14).Date = tmpDate
'===================================
'===================================
holidays(15).Name = "Veteran's Day"
'November 11 - Always
tmpDate = Dateserial(holidayYear, 11, 11)
holidays(15).Date = tmpDate
'===================================
'===================================
holidays(16).Name = "Thanksgiving"
'4th Thursday in November - this means it can
fall anywhere between
Nov. 22 and Nov. 28
tmpDate = Dateserial(holidayYear, 11, 22)
wkDay = Weekday(tmpDate)
holidays(16).Date = tmpDate - wkDay + 5
'Subtract the current day, add
5 for Thursday
If wkDay > 5 Then
holidays(16).Date = holidays(16).Date + 7
'Add 7 to go to next
week
End If
'===================================
'===================================
holidays(17).Name = "Christmas Day"
'December 25 - Always
tmpDate = Dateserial(holidayYear, 12, 25)
holidays(17).Date = tmpDate
'===================================
Forall h In holidays
tmpString = tmpString & Chr(13) &
Format(h.Date, "yyyy.mm.dd")
& Chr(9) & h.Name
End Forall
Msgbox Mid$(tmpString, 2), , "USA Holidays for "
& Cstr(holidayYear)
Goto endFunc
errHandler:
Msgbox "Invalid year entered"
Resume endFunc
endFunc:
End Sub
Function dateEaster(y As Integer) As Variant
'See http://aa.usno.navy.mil/faq/docs/easter.html
Dim c As Integer
Dim n As Integer
Dim k As Integer
Dim i As Integer
Dim j As Integer
Dim l As Integer
Dim m As Integer
Dim d As Integer
c = y \ 100
n = y - 19 * ( y \ 19 )
k = ( c - 17 ) 25
i = c - c \ 4 - ( c - k ) \ 3 +
19 * n + 15
i = i - 30 * ( i \ 30 )
i = i - ( i \ 28 ) * ( 1 - ( i \ 28 )
* ( 29 \ ( i + 1 ) ) *
( ( 21 - n ) \ 11 ) )
j = y + y 4 + i + 2 - c + c \ 4
j = j - 7 * ( j \ 7 )
l = i - j
m = 3 + ( l + 40 ) \ 44
d = l + 28 - 31 * ( m \ 4 )
dateEaster = Dateserial(y, m, d)
End Function
Do you have comments on this tip? Let us know.
This tip was submitted to the SearchDomino.com tip exchange by member Cesar Mugnatto. Please let others know how useful it is via the rating scale below. Do you have a useful Notes/Domino tip or code to share? Submit it to our monthly tip contest and you could win a prize and a spot in our Hall of Fame.
