Follow along with the video below to see how to install our site as a web app on your home screen.
Note: This feature may not be available in some browsers.
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
'***************************************************************************************************************
' 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
'******************************************************
' 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