VB Forum / General / November 2004

which holidays are you interested in?

Christmas, boxing day & New year you should be able to work out, May-day
should pose no problems, Good Friday and Easter Sunday are fun, (I had a
routine for it years ago, but that is long gone) they fall on the first
weekend after the first full moon after the vernal equinox - easy when you
know :-)

Most of our holidays are on fixed days or the nearest Friday or Monday. Try
Googleing "UK Public Holidays" for a full list

I think you biggest problem is keeping it up to date, each political party
has different ideas and sometimes some of the holidays may change (ie the
Tories don't like May Day and want to replace it with St Georges Day)

Regards
Dave

Maybe there's a web service somewhere that does the calculations ?

I'm not from the UK, so I'm not familiar with your holidays; but I'll
guess they follow the same structures as here in the US... fixed dates
(holiday always occurs on the same day each year), lunar-based dates
(such as Good Friday), and ordinal dates (such as 1st Monday of January,
Last Monday in May, etc.) Fixed, repeating dates you know how to handle,
of course. You will need an algorithm to handle lunar-based dates as
they map out to different dates year for year (the Internet should help
you out here although I have a Good Friday routine somewhere in my
archives if you need it). That brings us to ordinal dates. Several years
ago, I had an article published in Visual Basic Developer magazine
(http://www.pinpub.com/ME2/Audiences/default.asp) under the title "It's
a Date... but Which One?" (October 2000 issue) which showed how to get
the dates for these type of dates. Below is the function to retrieve
ordinal dates along with the description of its argument list from that
article.

Rick - MVP

The parameter names were selected to suggest the values required and to
“sort of” read like a sentence – Ordinal DayName InMonth OfYear – when
displayed by Visual Basic’s Auto Quick Info feature. These four
parameters are all required and each must be specified when making a
call to this function.

The Ordinal parameter eventually becomes a number between one and five
so you may enter it that way directly. This parameter may also be
entered as 1st, 2nd, 3rd, 4th and Last for readability purposes if you
wish. Actually, only the first character is examined so 1, 1st, 1xxx,
1week, etc. all evaluate to the same value – the digit one. The function
recognizes an Ordinal of Last (for the last such and such in . . .) but
converts this to the digit five for use inside the routine. This fifth
occurrence of a certain day within a month is automatically assumed to
be the Last occurrence within the month.

You can pass the actual name for the day of the week into the DayName
parameter. Only the first two characters are significant, so Tu, Tue,
Tuesday, Tusdey, TuBad, etc. will all refer to Tuesday. You may also
refer to the DayName by its numerical value – 1 for Sunday, 2 for
Monday, etc. These are the same values returned by Visual Basic’s
WeekDay function, which can be used to supply the value for this
parameter directly.
You can pass the actual name for the month into the InMonth parameter.
Only the first three characters are significant so Mar, Mark, March,
MarxBrothers, etc. will all refer to the month of March. You may also
assign values to the InMonth parameter by using a month’s numerical
designation – 1 for January, 2 for February, etc.

As for the OfYear parameter, it must simply be a four-digit number.
Beware, however, dates before 1582 are probably meaningless due to a ten
day calendar adjustments implemented by Pope Gregory XIII (hence the
name Gregorian Calendar) in that year. Actually, 1582 is not the best
“cutoff” year to use, as the Gregorian Calendar was not uniformly
adopted worldwide when it was first decreed. (For example, the English
and their American colonies didn’t adopt the Gregorian Calendar until
the middle of the eighteenth century.) Hence, you may want to implement
code to restrict the earliest year (normally 1753) that can be inputted
if you permit the year to be entered directly by your users.

All erroneous parameter input is trapped by the OrdinalDate function. A
value of 9/9/9999 is returned for all errors and may be checked for
before attempting to use the returned date.

Function OrdinalDate(ByVal Ordinal As String, _
                    ByVal DayName As String, _
                    ByVal InMonth As String, _
                    ByVal OfYear As Long) As Date
  Dim LD As Integer
  Dim LDNum As Integer
  Dim DayOne As Integer
  Dim OrdinalNum As Integer
  Dim DayNum As Integer
  Dim MonthNum As Integer
  Const DayNames = "*SU*MO*TU*WE*TH*FR*SA*"
  Const MonthNames = "*JAN*FEB*MAR*APR*MAY*JUN" & _
                    "*JUL*AUG*SEP*OCT*NOV*DEC*"
  'Convert Ordinal to integer
  Ordinal = UCase$(Left$(Ordinal, 1))
  If Ordinal = "L" Then
     OrdinalNum = 5
  ElseIf IsNumeric(Ordinal) Then
     OrdinalNum = CInt(Ordinal)
  Else
     OrdinalDate = 0
  End If
  'Convert name of day to Weekday numerical value
  If DayName Like "[1-7]" Then
     DayNum = CInt(DayName)
  Else
     DayName = Left$(DayName & "  ", 2)
     DayName = "*" & UCase(DayName) & "*"
     DayNum = (InStr(DayNames, DayName) + 2) \ 3
  End If
  'Convert name of month to its numerical value
  If IsNumeric(InMonth) Then
     MonthNum = Val(InMonth)
     If MonthNum < 0 Or MonthNum > 12 Then
        MonthNum = 0
     Else
        MonthNum = CInt(InMonth)
     End If
  Else
     InMonth = Left$(InMonth & "   ", 3)
     InMonth = "*" & UCase$(InMonth) & "*"
     MonthNum = (3 + InStr(MonthNames, InMonth)) \ 4
  End If
  'A date of 9/9/9999 is returned for invalid input
  If OrdinalNum < 1 Or OrdinalNum > 5 Or _
        DayNum = 0 Or MonthNum = 0 Or _
        OfYear < 1000 Or OfYear > 9999 Then
     OrdinalDate = DateSerial(9999, 9, 9)
     Exit Function
  End If
  'Find Ordinal DayName InMonth OfYear sought
  If OrdinalNum < 5 Then
     'Find Weekday numerical value for first of month
     DayOne = Weekday(DateSerial(OfYear, MonthNum, 1))
     'Find first DayName in first week of month
     OrdinalDate = DateSerial(OfYear, MonthNum, _
                   1 + (7 + DayNum - DayOne) Mod 7)
     'Adjust for week we are really interested in
     OrdinalDate = OrdinalDate + 7 * (OrdinalNum - 1)
  'Find Last DayName InMonth OfYear sought
  Else
     'Find Weekday value for last day of month
     LD = Weekday(DateSerial(OfYear, MonthNum + 1, 0))
     'Find day number of last day of month
     LDNum = Day(DateSerial(OfYear, MonthNum + 1, 0))
     'Adjust to last DayName of month
     OrdinalDate = DateSerial(OfYear, MonthNum, _
                   LDNum + ((DayNum - LD - 7) Mod 7))
  End If
End Function

Gary --

Here are a couple of routines I wrote several years ago when I had to write
a calendar program.  A couple of them were published on the old VB2TheMax
website.  Here's the url for GetRoshHashanah that was rewritten by the
authors in VB Net format: http://www.devx.com/vb2themax/Tip/19580 .  Hope
these help, I haven't looked at them in years.  Watch for word wrapping.

Jim Edgar

Public Function GetNOccuranceOfXDay(ByVal iMonth As Integer, ByVal iYear As Integer, ByVal
iDayOfWeek As Integer, ByVal iOccuranceOfDay As Integer) As Date
   ' Returns the date of a specified occurance of a requested day of the week.
   ' iMonth:           Month (1 = January and 12 = December) to search.
   ' iYear:            Year to search
   ' iDayOfWeek:       Day of the week (0 = Sunday, ... , 6 = Saturday) to find.
   ' iOccuranceOfDay:  Which occurance of the day within the month.
   '                   ie. First Monday, Second Tuesday, etc...
   '                   If iOccuranceOfDay is greater than the number of
   '                   times as particular day occurs within the month
   '                   then the last occurance of the day is returned.

   ' Do some checking.
   If iOccuranceOfDay < 1 Then iOccuranceOfDay = 1
   ' No days will appear more than six times in any month
   If iOccuranceOfDay > 6 Then iOccuranceOfDay = 6
   ' Days must be between 0 and 6
   If iDayOfWeek < 0 Then iDayOfWeek = 0
   If iDayOfWeek > 6 Then iDayOfWeek = 6

   Dim dt As Date, iFound As Integer

   ' Start counting at the first day of the month
   dt = CDate(iMonth & "/1/" & iYear)

   iFound = GetWeekdayInteger(dt)

   ' Search for the first occurance of the day.
   Do While (iFound <> iDayOfWeek)
       ' Increment the date by one day if it is not found
       dt = DateAdd("d", 1, dt)
       ' Increment the iFound variable
       iFound = IIf((iFound + 1) > 6, iFound = 0, iFound + 1)
   Loop

   ' We have now found the date of the first occurance of the specified
   ' weekday in the requested month.  Now we increment the value if need
   ' be.

   Select Case iOccuranceOfDay
       Case 1  ' First occurance
           ' Do nothing. We are already there.
       Case Else
           ' Add the appropriate number of weeks to the date.
           ' If we want the second occurance then we add 1 week,
           ' if we want the third occurance then add 2 weeks, etc...
           dt = DateAdd("ww", iOccuranceOfDay - 1, dt)
   End Select

   ' We need to check to see if we are still in the requested month and year.
   ' The following code just
   ' decrements the date until we are back in the requested month, in effect
   ' we are giving the last occurance of a day within a month.  This is
   ' useful if we need the last Friday in March.

   Do While (iMonth <> Month(dt))
       dt = DateAdd("ww", -1, dt)
   Loop

   GetNOccuranceOfXDay = dt

End Function

Public Function GetOrthodoxEaster(iYear As Integer) As Date
   Dim iRet As Integer, JulianToGregorian As Integer

   ' condensed VB code by Jim Edgar

   ' Factor to convert from Julian date to Gregorian date
   JulianToGregorian = Int(iYear / 100) - Int(iYear / 400) - 2   ' 13 until after
3/1/2100

   iRet = JulianToGregorian + ((2 * (iYear Mod 4) + 4 * (iYear Mod 7) + 6 * ((19 * (iYear
Mod 19) + 16) Mod 30)) Mod 7) + ((19 * (iYear Mod 19) + 16) Mod 30)

   GetOrthodoxEaster = DateAdd("d", iRet, CDate("March/21/" & iYear))

End Function

Private Function GetEaster(ByVal iYear As Integer) As Date

   Dim g As Long, c As Long, x As Long, z As Long, d As Long, e As Long
   Dim n As Long, iMonth As Integer, iDay As Integer

   g = (iYear Mod 19) + 1          ' golden year in 19-year Metonic cycle
   c = Int(iYear / 100) + 1       ' century
   x = Int(3 * c / 4) - 12        ' number of leap years that were
                                   ' dropped
   z = Int((8 * c + 5) / 25) - 5  ' correction to synchronize Easter
                                   ' with moon's orbit
   d = Int(5 * iYear / 4) - x - 10    ' factor to adjust date to following
                                   ' Sunday
   e = Abs(11 * g + 20 + z - x) Mod 30 'when full moon occurs
   ' Easter is first Sunday following the first full moon that
   ' occurs on or after March 21.
   If (e = 25 And g > 11) Or (e = 24) Then e = e + 1
   n = 44 - e
   If (n < 21) Then n = n + 30
   n = n + 7 - ((d + n) Mod 7)

   If (n > 31) Then    ' Easter falls in April instead of March
       iMonth = 4
       iDay = n - 31
   Else
       iMonth = 3
       iDay = n
   End If

   GetEaster = CDate(iMonth & "/" & iDay & "/" & iYear)

End Function

Public Function GetRoshHashanah(iYear As Integer) As Date

   ' This function returns the date that Rosh Hashanah begins
   ' for the requested year.  It is important to note that
   ' Rosh Hashanah is based on the Lunar cycle so the Holiday
   ' actually begins at sunset of the day before the date
   ' returned by this function.

   Dim dDate As Single, iDate As Integer, iDayOfWeek As Integer
   Dim JY As Integer, JtoG As Integer, sMonth As String

   ' Conversion factors
   Const F1 As Single = 765433 / 492480
   Const F2 As Single = 23269 / 25920
   Const F3 As Single = 765433 / 492480

   JY = (12 * ((iYear Mod 19) + 1)) Mod 19

   ' Correct from Julian date to Gregorian date
   JtoG = Int(iYear / 100) - Int(iYear / 400) - 2

   dDate = JtoG + (F1 * JY) + ((iYear Mod 4) / 4) - ((313 * CLng(iYear) + 89081) / 98496)

   ' Get the integer portion of the date
   iDate = Int(dDate)
   ' Get the fractional portion of the date
   dDate = dDate - iDate

   If iDate > 30 Then
       iDate = iDate - 30
       sMonth = "October"
   Else
       sMonth = "September"
   End If

   iDayOfWeek = GetWeekdayInteger(CDate(sMonth & "/" & iDate & "/" & iYear))
   ' Postponement Rules
   ' If day of week is Sunday, Wednesday, or Friday
   If iDayOfWeek = 0 Or iDayOfWeek = 3 Or iDayOfWeek = 5 Then
       iDate = iDate + 1
   ' If day is Monday
   ElseIf iDayOfWeek = 1 And dDate > F1 And JY > 11 Then
       iDate = iDate + 1
   ' If day is Tuesday we may need to add two days
   ElseIf iDayOfWeek = 2 And dDate >= F2 And JY > 6 Then
       iDate = iDate + 2
   End If

   If iDate > 30 Then
       iDate = iDate - 30
       sMonth = "September"
   End If

   GetRoshHashanah = CDate(sMonth & "/" & iDate & "/" & iYear)

End Function