'******************************************************
' 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
