Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Register Log in
  • Congratulations Mike Lewis on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

How To Determine any Holiday

VB Programming Concepts

How To Determine any Holiday

by  ArtieChoke  Posted    (Edited  )
This FAQ shows how to determine any holiday that's based on an exact date or falls on a specific weekday and week. All code was developed by me unless specified otherwise and can be used freely.

There are two classes to support this - one that finds regular holidays and Easter. The other one finds four Jewish holidays. The following code demonstrates how to use the routines.

Code: 
Option Explicit

Private Sub main()

'   Retrives holidays for a period of time

    Dim holi As New Holidays
    Dim jc As New JewishCalendar
    
    Dim days
    Dim dow
    Dim months
    Dim names
    
    Dim i As Integer
    Dim reqYear As Integer
    Dim reqEndYear As Integer
    Dim reqStartYear As Integer
    
'   Set up the following holidays:
'   New Years, President's day, Memorial day, Independence day, Labor day, Thanksgiving and Xmas
    
    months = Array(1, 2, 5, 7, 9, 11, 12)

'   For holidays that start in a specific week,
'   use a week constant (from the holiday class) for the day
    
    days = Array(1, holi.ThirdWeek, holi.LastWeek, 4, holi.FirstWeek, holi.ForthWeek, 25)
    
'   For holidays that start on a specific day of the week, use a VB day constant,
'   otherwise use 0

    dow = Array(0, vbMonday, vbMonday, 0, vbMonday, vbThursday, 0)

    names = Array("New Years", "President's day", "Memorial day", _
    "Independence day", "Labor day", "Thanksgiving", "Xmas")
    
    reqStartYear = 2004
    reqEndYear = 2004
    
'   Set to adjust holidays if they fall on a weekend to a weekday
    
    holi.AdjustForWeekends = True
    For reqYear = reqStartYear To reqEndYear
        For i = 0 To UBound(months)
            holi.Day = days(i)
            holi.Month = months(i)
            holi.DayOfWeek = dow(i)
            Debug.Print names(i), holi.NextHoliday(reqYear)
        Next

'   Good Friday and Easter

        Debug.Print "Good Friday", DateAdd("d", -2, holi.NextEaster(reqYear))
        Debug.Print "Easter", holi.NextEaster(reqYear)
        
'   Jewish holdiays

        jc.GregorianYear = reqYear
        Debug.Print "Chanukkah", jc.Chanukkah
        Debug.Print "Passover", jc.Passover
        Debug.Print "RoshHashanah", jc.RoshHashanah
        Debug.Print "YomKippur", jc.YomKippur
    Next
    End
    
End Sub

[green]This class will generate regular holidays and Easter. Except for the Easter calculation (which I got from some VB code sites and adapted), all the algorithms were developed by me.[/green]

Code: 
'***************************************************************************************************************
'               Calculates yearly holidays or events
'***************************************************************************************************************

Option Explicit

Private rcAdjustForWeekends As Boolean
Private rcDay As Integer
Private rcDOW As Integer
Private rcMonth As Integer

Private Const rcFirst = -1
Private Const rcSecond = -2
Private Const rcThird = -3
Private Const rcFourth = -4
Private Const rcLast = -5

Public Property Let AdjustForWeekends(b As Boolean)

'   Determines whether to adjust holiday if it falls on a weekend

    rcAdjustForWeekends = b
    
End Property

Public Property Let Day(d As Integer)

'   Set day of month or Nth week in month

    rcDay = d
    
End Property

Public Property Let DayOfWeek(d As Integer)

'   Set day of week when using Nth week

    rcDOW = d
    
End Property

Public Property Let Month(m As Integer)

'   Set year

    rcMonth = m
    
End Property

Public Function NextEaster(reqYear As Integer) As Date

    Dim d As Integer
    Dim m As Integer
    
    EasterDate reqYear, d, m
    NextEaster = DateSerial(reqYear, m, d)

End Function

Public Function NextHoliday(reqYear As Integer) As Date

'   Finds the yearly date for the holiday for the year requested
    
    If rcDay > 0 Then
        
'   Set specific day and month of current year

        NextHoliday = DateSerial(reqYear, rcMonth, rcDay)
        If rcAdjustForWeekends Then
        
'   Adjust date to previous Friday or following Monday if it falls on a weekend
        
            Select Case Weekday(NextHoliday)
                Case vbSaturday
                    NextHoliday = DateAdd("d", -1, NextHoliday)
                
                Case vbSunday
                    NextHoliday = DateAdd("d", 1, NextHoliday)
            End Select
        End If
    Else
    
'   Nth day type - Nth day routine uses year of date passed

        NextHoliday = NextNthDay(reqYear)
    End If
    
End Function

'   Week constants

Public Property Get FirstWeek()

    FirstWeek = rcFirst
    
End Property

Public Property Get SecondWeek()

    SecondWeek = rcSecond
    
End Property

Public Property Get ThirdWeek()

    ThirdWeek = rcThird
    
End Property

Public Property Get ForthWeek()

    ForthWeek = rcFourth
    
End Property

Public Property Get LastWeek()

    LastWeek = rcLast
    
End Property

'******************************************************
'   Private routines
'******************************************************

Private Sub EasterDate(y As Integer, d As Integer, m As Integer)
    
    Dim FirstDig, Remain19, temp 'intermediate results
    Dim tA, tB, tC, tD, tE 'table A To E results
    FirstDig = y \ 100 'first 2 digits of year
    Remain19 = y Mod 19 'remainder of year /
    
'   calculate PFM date
    
    temp = (FirstDig - 15) \ 2 + 202 - 11 * Remain19
    If FirstDig > 26 Then temp = temp - 1
    If FirstDig > 38 Then temp = temp - 1
    If ((FirstDig = 21) Or (FirstDig = 24) Or (FirstDig = 25) _
    Or (FirstDig = 33) Or (FirstDig = 36) Or (FirstDig = 37)) _
    Then temp = temp - 1
    temp = temp Mod 30
    tA = temp + 21
    If temp = 29 Then tA = tA - 1
    If (temp = 28 And Remain19 > 10) Then tA = tA - 1
    
'   find the next Sunday

    tB = (tA - 19) Mod 7
    tC = (40 - FirstDig) Mod 4
    If tC = 3 Then tC = tC + 1
    If tC > 1 Then tC = tC + 1
    temp = y Mod 100
    tD = (temp + temp \ 4) Mod 7
    tE = ((20 - tB - tC - tD) Mod 7) + 1
    d = tA + tE

    If d > 31 Then
        d = d - 31
        m = 4
    Else
        m = 3
    End If
    
End Sub

Private Function NextNthDay(reqYear As Integer) As Date

'   Finds the next available Nth day ie 2nd Saturday, etc.
'   in the current year passed

    Dim nextdate As Date
    Dim curday As Integer
  
'   Create a date with the end of the previous month which will
'   be used to roll forward from into the next month unless last n,
'   then will roll backward from the beginning of the next month
    
    nextdate = DateSerial(reqYear, rcMonth, 1)
    If rcDay = rcLast Then
        nextdate = DateAdd("m", 1, nextdate)
    Else
        nextdate = DateAdd("d", -1, nextdate)
    End If
    curday = Weekday(nextdate)
    
    If rcDay = rcLast Then
    
'   Last day requires special processing

        If rcDOW < curday Then
            nextdate = DateAdd("d", rcDOW - curday, nextdate)
        Else
            nextdate = DateAdd("d", (rcDOW - curday) - 7, nextdate)
        End If
    Else
        If rcDOW > curday Then
            nextdate = DateAdd("d", rcDOW - curday, nextdate)
        Else
            nextdate = DateAdd("d", 7 - (curday - rcDOW), nextdate)
        End If
        nextdate = DateAdd("ww", Abs(rcDay) - 1, nextdate)
    End If
    NextNthDay = nextdate
    
End Function

[green]This class provides the calculations for the Jewish holidays. These calculations were also found on the web and converted to VB by me.[/green]

Code: 
'******************************************************
'   Gregorian <==> Hebrew Calendar Conversion
'******************************************************

Option Explicit

Const HebrewEpoch = -1373429  ' Absolute date of start of Hebrew calendar

Private AD As Long
Private gyear As Integer
Private hyear As Integer

'------------------------------------------------------
'   Conversion routines
'------------------------------------------------------

Property Get Gregorian() As Date

'   Return a gregorian date

    Dim m As Integer, d As Integer, y As Integer
    
    ADtoGregorianDate AD, m, d, y
    Gregorian = DateSerial(y, m, d)
    
End Property

Property Let Gregorian(tdate As Date)

'   Set a gregorian date

    AD = GregorianDatetoAD(Month(tdate), Day(tdate), year(tdate))
    
End Property

Property Let GregorianYear(y As Integer)

'   Set the gregorian year for jewish holiday calcs
    
    Dim m As Integer, d As Integer
    Dim gad As Long

    gyear = y

'   Calc the starting year for jewish holiday calcs
    
    gad = GregorianDatetoAD(1, 1, y)
    ADtoHebrewDate gad, m, d, hyear
    
End Property

Property Get Hebrew() As Date

'   Return a Hebrew date

    Dim m As Integer, d As Integer, y As Integer
    
    ADtoHebrewDate AD, m, d, y
    Hebrew = DateSerial(y, m, d)
    
End Property

Property Let Hebrew(tdate As Date)

'   Set a Hebrew date

    AD = HebrewDatetoAD(Month(tdate), Day(tdate), year(tdate))
    
End Property

'------------------------------------------------------
'   Holiday routines
'------------------------------------------------------

Property Get Chanukkah() As Date

'   Return the gregorian date for Chanukkah
    
    Dim m As Integer, d As Integer, y As Integer
    Dim gad As Long

    gad = HebrewDatetoAD(9, 25, hyear + 1)
    ADtoGregorianDate gad, m, d, y
    Chanukkah = DateSerial(y, m, d)
    
End Property

Property Get Passover() As Date

'   Return the gregorian date for Passover
    
    Dim m As Integer, d As Integer, y As Integer
    Dim gad As Long

    gad = HebrewDatetoAD(1, 15, hyear)
    ADtoGregorianDate gad, m, d, y
    Passover = DateSerial(y, m, d)
    
End Property

Property Get RoshHashanah() As Date

'   Return the gregorian date for Rosh Hashanah
    
    Dim m As Integer, d As Integer, y As Integer
    Dim gad As Long

    gad = HebrewDatetoAD(7, 1, hyear + 1)
    ADtoGregorianDate gad, m, d, y
    RoshHashanah = DateSerial(y, m, d)
    
End Property

Property Get YomKippur() As Date

'   Return the gregorian date for Yom Kippur
    
    Dim m As Integer, d As Integer, y As Integer
    Dim gad As Long

    gad = HebrewDatetoAD(7, 10, hyear + 1)
    ADtoGregorianDate gad, m, d, y
    YomKippur = DateSerial(y, m, d)
    
End Property

'******************************************************
'   Private routines here
'******************************************************

Private Function LastDayOfGregorianMonth(Month As Integer, year As Integer) As Integer

'   Compute the last date of the month for the Gregorian calendar.
  
    Select Case Month
        Case 2
            If (year Mod 4 = 0 And year Mod 100 <> 0) Or year Mod 400 = 0 Then
                LastDayOfGregorianMonth = 29
            Else
                LastDayOfGregorianMonth = 28
            End If
        Case 4, 6, 9, 11
            LastDayOfGregorianMonth = 30
        Case Else
            LastDayOfGregorianMonth = 31
   End Select
  
End Function

Private Sub ADtoGregorianDate(d As Long, Month As Integer, Day As Integer, year As Integer)

'   Computes the Gregorian date from the absolute date.
'   Search forward year by year from approximate year

    year = d / 366
    While d >= GregorianDatetoAD(1, 1, year + 1)
        year = year + 1
    Wend
    
'   Search forward month by month from January

    Month = 1
    While d > GregorianDatetoAD(Month, LastDayOfGregorianMonth(Month, year), year)
        Month = Month + 1
    Wend
    
    Day = d - GregorianDatetoAD(Month, 1, year) + 1
    
End Sub

Private Function GregorianDatetoAD(Month As Integer, Day As Integer, year As Integer) As Long

'   Computes the absolute date from the Gregorian date.

    Dim N As Integer
    Dim m As Integer
    Dim y As Long
    
    N = Day           ' days this month
    For m = Month - 1 To 1 Step -1 ' days in prior months this year
        N = N + LastDayOfGregorianMonth(m, year)
    Next
    
    y = year
    GregorianDatetoAD = N + 365 * (y - 1) + (year - 1) \ 4 _
    - (year - 1) \ 100 + (year - 1) \ 400

End Function

Private Function HebrewLeapYear(year As Integer) As Boolean

'   True if year is an Hebrew leap year
  
    Dim y As Long
    
    y = year
    If (7 * y + 1) Mod 19 < 7 Then
        HebrewLeapYear = True
    Else
        HebrewLeapYear = False
    End If

End Function

Private Function LastMonthOfHebrewYear(year As Integer) As Integer

'   Last month of Hebrew year.
  
    If HebrewLeapYear(year) Then
        LastMonthOfHebrewYear = 13
    Else
        LastMonthOfHebrewYear = 12
    End If
    
End Function

Private Function HebrewCalendarElapsedDays(year As Integer) As Long

'   Number of days elapsed from the Sunday prior to the start of the
'   Hebrew calendar to the mean conjunction of Tishri of Hebrew year.
  
    Dim MonthsElapsed As Long
    Dim PartsElapsed As Long
    Dim HoursElapsed As Long
    Dim ConjunctionDay As Long
    Dim ConjunctionParts As Long
    Dim AlternativeDay As Long
    Dim y As Long
  
    y = year
    MonthsElapsed = (235 * ((y - 1) \ 19)) + (12 * ((year - 1) Mod 19)) _
    + (7 * ((year - 1) Mod 19) + 1) \ 19
    PartsElapsed = 204 + 793 * (MonthsElapsed Mod 1080)
    HoursElapsed = 5 + 12 * MonthsElapsed + 793 * (MonthsElapsed \ 1080) _
    + PartsElapsed \ 1080
    ConjunctionDay = 1 + 29 * MonthsElapsed + HoursElapsed \ 24
    ConjunctionParts = 1080 * (HoursElapsed Mod 24) + PartsElapsed Mod 1080
  
    If ConjunctionParts >= 19440 _
    Or (ConjunctionDay Mod 7 = 2 And ConjunctionParts >= 9924 And Not HebrewLeapYear(year)) _
    Or (ConjunctionDay Mod 7 = 1 And ConjunctionParts >= 16789 And HebrewLeapYear(year - 1)) Then
    
'   Postpone Rosh HaShanah one day

        AlternativeDay = ConjunctionDay + 1
    Else
        AlternativeDay = ConjunctionDay
    End If
    
    If (((AlternativeDay Mod 7) = 0) Or ((AlternativeDay Mod 7) = 3) _
    Or ((AlternativeDay Mod 7) = 5)) Then AlternativeDay = 1 + AlternativeDay

    HebrewCalendarElapsedDays = AlternativeDay
    
End Function

Private Function DaysInHebrewYear(year As Integer) As Integer

'   Number of days in Hebrew year.
  
    DaysInHebrewYear = HebrewCalendarElapsedDays(year + 1) - HebrewCalendarElapsedDays(year)

End Function

Private Function LongHeshvan(year As Integer) As Boolean

'   True if Heshvan is long in Hebrew year.
  
    If DaysInHebrewYear(year) Mod 10 = 5 Then
        LongHeshvan = True
    Else
        LongHeshvan = False
    End If
    
End Function

Private Function ShortKislev(year As Integer) As Boolean

'   True if Kislev is short in Hebrew year.
  
    If DaysInHebrewYear(year) Mod 10 = 3 Then
        ShortKislev = True
    Else
        ShortKislev = False
    End If
    
End Function

Private Function LastDayOfHebrewMonth(Month As Integer, year As Integer) As Integer

'   Last day of month in Hebrew year.
  
    If Month = 2 Or Month = 4 Or Month = 6 Or Month = 10 Or Month = 13 _
    Or (Month = 8 And Not LongHeshvan(year)) _
    Or (Month = 9 And ShortKislev(year)) _
    Or (Month = 12 And Not HebrewLeapYear(year)) Then
        LastDayOfHebrewMonth = 29
    Else
        LastDayOfHebrewMonth = 30
    End If
    
End Function

Private Sub ADtoHebrewDate(d As Long, Month As Integer, Day As Integer, year As Integer)

'   Computes the Hebrew date from the absolute date.

    year = (d + HebrewEpoch) / 366 ' Approximation from below.
    
'   Search forward for year from the approximation.

    While d >= HebrewDatetoAD(7, 1, year + 1)
        year = year + 1
    Wend
    
'   Search forward for month from either Tishri or Nisan.

    If d < HebrewDatetoAD(1, 1, year) Then
        Month = 7  '  Start at Tishri
    Else
        Month = 1  '  Start at Nisan
    End If
    
    While d > HebrewDatetoAD(Month, (LastDayOfHebrewMonth(Month, year)), year)
        Month = Month + 1
    Wend
    
'   Calculate the day by subtraction.

    Day = d - HebrewDatetoAD(Month, 1, year) + 1
    
End Sub

Private Function HebrewDatetoAD(Month As Integer, Day As Integer, year As Integer) As Long

'   Computes the absolute date of Hebrew date.

    Dim DayInYear As Integer
    Dim m As Integer
    
    DayInYear = Day ' Days so far this month.
    If Month < 7 Then
        m = 7
        While m <= LastMonthOfHebrewYear(year)
            DayInYear = DayInYear + LastDayOfHebrewMonth(m, year)
            m = m + 1
        Wend
        
        m = 1
        While m < Month
            DayInYear = DayInYear + LastDayOfHebrewMonth(m, year)
            m = m + 1
        Wend
    Else
        m = 7
        While m < Month
            DayInYear = DayInYear + LastDayOfHebrewMonth(m, year)
            m = m + 1
        Wend
    End If
    HebrewDatetoAD = DayInYear + HebrewCalendarElapsedDays(year) + HebrewEpoch

End Function
Register to add this FAQ to your archive
Register to rate this FAQ  : BAD 1 2 3 4 5 6 7 8 9 10 GOOD
Please Note: 1 is Bad, 10 is Good :-)

Part and Inventory Search

Back
Top