mod_hdateformat.bas

Attribute VB_Name = "mod_hdateformat"
Public hchar(24) As String
Public hmonth(13) As String
Public hwday(7) As String
Public parshahchar(61) As String
Public hdateformat_ready As Boolean

Public Sub init_hdateformat()
    hchar(0) = "?"
    hchar(1) = "à"
    hchar(2) = "á"
    hchar(3) = "â"
    hchar(4) = "ã"
    hchar(5) = "ä"
    hchar(6) = "å"
    hchar(7) = "æ"
    hchar(8) = "ç"
    hchar(9) = "è"
    hchar(10) = "é"
    hchar(11) = "ë"
    hchar(12) = "ì"
    hchar(13) = "î"
    hchar(14) = "ð"
    hchar(15) = "ñ"
    hchar(16) = "ò"
    hchar(17) = "ô"
    hchar(18) = "ö"
    hchar(19) = "÷"
    hchar(20) = "ø"
    hchar(21) = "ù"
    hchar(22) = "ú"
    hchar(23) = "Ø"
    hchar(24) = "×"
    hmonth(0) = "àãø à×"
    hmonth(1) = "ðéñï"
    hmonth(2) = "àééø"
    hmonth(3) = "ñéåï"
    hmonth(4) = "úîåæ"
    hmonth(5) = "àá"
    hmonth(6) = "àìåì"
    hmonth(7) = "úùøé"
    hmonth(8) = "çùåï"
    hmonth(9) = "ëñìå"
    hmonth(10) = "èáú"
    hmonth(11) = "ùáè"
    hmonth(12) = "àãø"
    hmonth(13) = "àãø á×"
    hwday(0) = "ùáéòé"
    hwday(1) = "øàùåï"
    hwday(2) = "ùðé"
    hwday(3) = "ùìéùé"
    hwday(4) = "øáéòé"
    hwday(5) = "çîéùé"
    hwday(6) = "ùéùé"
    hwday(7) = "ùáú"
    parshahchar(0) = ""
    parshahchar(1) = "áøàùéú"
    parshahchar(2) = "ðç"
    parshahchar(3) = "ìê ìê"
    parshahchar(4) = "åéøà"
    parshahchar(5) = "çéé ùøä"
    parshahchar(6) = "úåìãåú"
    parshahchar(7) = "åéöà"
    parshahchar(8) = "åéùìç"
    parshahchar(9) = "åéùá"
    parshahchar(10) = "î÷õ"
    parshahchar(11) = "åéâù"
    parshahchar(12) = "åéçé"
    parshahchar(13) = "ùîåú"
    parshahchar(14) = "åàøà"
    parshahchar(15) = "áà"
    parshahchar(16) = "áùìç"
    parshahchar(17) = "éúøå"
    parshahchar(18) = "îùôèéí"
    parshahchar(19) = "úøåîä"
    parshahchar(20) = "úöåä"
    parshahchar(21) = "ëé úùà"
    parshahchar(22) = "åé÷äì"
    parshahchar(23) = "ô÷åãé"
    parshahchar(24) = "åé÷øà"
    parshahchar(25) = "öå"
    parshahchar(26) = "ùîéðé"
    parshahchar(27) = "úæøéò"
    parshahchar(28) = "îöåøò"
    parshahchar(29) = "àçøé îåú"
    parshahchar(30) = "÷ãåùéí"
    parshahchar(31) = "àîåø"
    parshahchar(32) = "áäø"
    parshahchar(33) = "áçå÷åúé"
    parshahchar(34) = "áîãáø"
    parshahchar(35) = "ðùà"
    parshahchar(36) = "áäòìåúê"
    parshahchar(37) = "ùìç"
    parshahchar(38) = "÷øç"
    parshahchar(39) = "ç÷ú"
    parshahchar(40) = "áì÷"
    parshahchar(41) = "ôéðçñ"
    parshahchar(42) = "îèåú"
    parshahchar(43) = "îñòé"
    parshahchar(44) = "ãáøéí"
    parshahchar(45) = "åàúçðï"
    parshahchar(46) = "ò÷á"
    parshahchar(47) = "øàä"
    parshahchar(48) = "ùåôèéí"
    parshahchar(49) = "ëé úöà"
    parshahchar(50) = "ëé úáåà"
    parshahchar(51) = "ðöáéí"
    parshahchar(52) = "åéìê"
    parshahchar(53) = "äàæéðå"
    parshahchar(54) = "åæàú äáøëä"
    parshahchar(55) = "åé÷äì - ô÷åãé"
    parshahchar(56) = "úæøéò - îöåøò"
    parshahchar(57) = "àçøé îåú - ÷ãåùéí"
    parshahchar(58) = "áäø - áçå÷åúé"
    parshahchar(59) = "ç÷ú - áì÷"
    parshahchar(60) = "îèåú - îñòé"
    parshahchar(61) = "ðöáéí - åéìê"
    
    
    
    hdateformat_ready = True
End Sub

Public Function ParshahFormat(current As parshah) As String
    If hdateformat_ready = False Then init_hdateformat
    
    ParshahFormat = parshahchar(current)
End Function

Function GetHChar(ByVal num As Integer) As String
    Dim hchar1 As String
    If hdateformat_ready = False Then init_hdateformat
    Select Case num
        Case 1
            hchar1 = hchar(1)
        Case 2
            hchar1 = hchar(2)
        Case 3
            hchar1 = hchar(3)
        Case 4
            hchar1 = hchar(4)
        Case 5
            hchar1 = hchar(5)
        Case 6
            hchar1 = hchar(6)
        Case 7
            hchar1 = hchar(7)
        Case 8
            hchar1 = hchar(8)
        Case 9
            hchar1 = hchar(9)
        Case 10
            hchar1 = hchar(10)
        Case 20
            hchar1 = hchar(11)
        Case 30
            hchar1 = hchar(12)
        Case 40
            hchar1 = hchar(13)
        Case 50
            hchar1 = hchar(14)
        Case 60
            hchar1 = hchar(15)
        Case 70
            hchar1 = hchar(16)
        Case 80
            hchar1 = hchar(17)
        Case 90
            hchar1 = hchar(18)
        Case 100
            hchar1 = hchar(19)
        Case 200
            hchar1 = hchar(20)
        Case 300
            hchar1 = hchar(21)
        Case 400
            hchar1 = hchar(22)
        Case 99
            hchar1 = hchar(23)
        Case 999
            hchar1 = hchar(24)
        Case Else
            hchar1 = hchar(0)
    End Select
    GetHChar = hchar1
End Function

Function AddChar(ByVal year As String, ByVal charnum As Integer, ByRef num As Integer, ByRef counter As Long, ByVal limit As Long) As String
    Dim charvalue As Integer
    If hdateformat_ready = False Then init_hdateformat
    charvalue = charnum
    If charvalue = 99 Or charvalue = 999 Then charvalue = 0
    Dim Len1 As Long
    Len1 = limit - counter
    Dim endPos As Long
    endPos = counter + IIf(Len1 > 2, 2, Len1)
    Dim endStr As String
    endStr = Left$(year, counter) & GetHChar(charnum) & Mid$(year, endPos + 1)
    counter = counter + IIf(Len1 > 1, 1, Len1)
    num = num - charvalue
    AddChar = endStr
End Function

'convert an int to a Hebrew char based representation. 5779 becomes úùò"è
Public Function NumToHChar(ByVal innum As Integer) As String
    Dim num As Integer
    num = innum
    Dim year As String
    Dim counter As Long
    If hdateformat_ready = False Then init_hdateformat
    year = String(13, vbNullChar)
    counter = 0
    If num >= 1000 And num <= 10000 And num Mod 1000 = 0 Then
        year = AddChar(year, num \ 1000, num, counter, 13)
        year = AddChar(year, 999, num, counter, 13)
        NumToHChar = Left$(year, counter)
        Exit Function
    End If
    If num >= 1000 And num <= 10000 Then num = num Mod 1000
    Do While num > 0 And counter < 13
        If num = 15 Or num = 16 Then
            year = AddChar(year, 9, num, counter, 13)
            year = AddChar(year, 99, num, counter, 13)
            year = AddChar(year, num, num, counter, 13)
            NumToHChar = Left$(year, counter)
            Exit Function
        ElseIf num < 10 Or (num < 100 And num Mod 10 = 0) Or (num < 500 And num Mod 100 = 0) Then
            If counter <> 0 Then year = AddChar(year, 99, num, counter, 13)
            year = AddChar(year, num, num, counter, 13)
            NumToHChar = Left$(year, counter)
            If innum < 11 Then NumToHChar = NumToHChar + "'"
            Exit Function
        ElseIf num > 400 Then
            year = AddChar(year, 400, num, counter, 13)
            GoTo ContinueLoop
        ElseIf num > 300 Then
            year = AddChar(year, 300, num, counter, 13)
            GoTo ContinueLoop
        ElseIf num > 200 Then
            year = AddChar(year, 200, num, counter, 13)
            GoTo ContinueLoop
        ElseIf num > 100 Then
            year = AddChar(year, 100, num, counter, 13)
            GoTo ContinueLoop
        ElseIf num \ 10 > 0 Then
            year = AddChar(year, num - (num Mod 10), num, counter, 13)
            GoTo ContinueLoop
        End If
ContinueLoop:
    Loop
    NumToHChar = Left$(year, counter)
    If innum < 11 Then NumToHChar = NumToHChar + "'"
End Function

'convert int based Hebrew weekday (hdate.wday) to char based representation.
'second argument is a booean if to use ùáú (true) or ùáéòé (false)
Function NumToWDay(date_in As hdate, ByVal shabbos As Boolean) As String
    If hdateformat_ready = False Then init_hdateformat
    If shabbos And date_in.wday = 0 Then
        NumToWDay = hwday(7)
    Else
        NumToWDay = hwday(date_in.wday)
    End If
End Function

'convert int based Hebrew month (hdate.month) to char based representation.
Function NumToHMonth(ByVal month As Integer, ByVal leap As Integer) As String
    If hdateformat_ready = False Then init_hdateformat
    If leap <> 0 Then
        If month = 12 Then
            NumToHMonth = hmonth(0)
            Exit Function
        ElseIf month = 13 Then
            NumToHMonth = hmonth(month)
            Exit Function
        End If
    End If
    If month > 0 And month < 13 Then
        NumToHMonth = hmonth(month)
    Else
        NumToHMonth = vbNullString
    End If
End Function

'convert hdate to string based representation
Function HDateFormat(date_in As hdate) As String
    Dim day As String
    Dim year As String
    If hdateformat_ready = False Then init_hdateformat
    day = NumToHChar(date_in.day)
    Dim month As String
    month = NumToHMonth(date_in.month, date_in.leap)
    year = NumToHChar(date_in.year)
    HDateFormat = day & " " & month & " " & year
End Function

'convert hdate to string based representation, with evening consideration;
'if the time is between zais to sunrise of next day then add "àåø ì-" for next day
Function HDateOrFormat(date_in As hdate, here As location) As String
    Dim day As String
    Dim year As String
    Dim date_next As hdate
    Dim date_before As hdate
    Dim is_or As Boolean
    Dim sunset_today As Date
    Dim sunset_yesterday As Date
    Dim current_date As Date
    Dim sunrise_tomorrow As Date
    Dim date_result As hdate
    date_next = date_in
    date_before = date_in
    current_date = (HDateGregorian(date_in))
    Call HDateAddDay(date_next, 1)
    Call HDateAddDay(date_before, -1)
    sunset_today = (HDateGregorian(gettzais8p5(date_in, here)))
    sunrise_today = (HDateGregorian(getsunrise(date_in, here)))
    sunrise_tomorrow = (HDateGregorian(getsunrise(date_next, here)))
    sunset_yesterday = (HDateGregorian(gettzais8p5(date_before, here)))
    If current_date >= sunset_today Then
        is_or = True
        date_result = date_next
    Else
        date_result = date_in
    End If
    If current_date < sunrise_today Then is_or = True
    If hdateformat_ready = False Then init_hdateformat
    day = NumToHChar(date_result.day)
    Dim month As String
    month = NumToHMonth(date_result.month, date_result.leap)
    year = NumToHChar(date_result.year)
    HDateOrFormat = day & " " & month & " " & year
    If is_or Then HDateOrFormat = "àåø ì-" & HDateOrFormat
End Function

'convert hdate holding molad info to string representation, suitable for molad announcement
Function MoladFormat(molad As hdate, Optional full_date As Boolean = True) As String
    If full_date Then
        MoladFormat = "éåí " & NumToWDay(molad, True) & ", " & NumToHChar(molad.day) & " " & NumToHMonth(molad.month, molad.leap) & ", ùòä " & Format(TimeSerial(molad.hour, molad.min, 0), "hh:mm") & " å-" & molad.sec & " çì÷éí"
    Else
        MoladFormat = "éåí " & NumToWDay(molad, True) & " ùòä " & Format(TimeSerial(molad.hour, molad.min, 0), "hh:mm") & " å-" & molad.sec & " çì÷éí"
    End If
End Function

'convert yomtov enum to char based representation
Function YomTovFormat(ByVal current As yomtov) As String
    If hdateformat_ready = False Then init_hdateformat
    Select Case current
        Case CHOL
            YomTovFormat = ""
        Case PESACH_DAY1, PESACH_DAY2
            YomTovFormat = "ôñç"
        Case SHVEI_SHEL_PESACH
            YomTovFormat = "ùáéòé ùì ôñç"
        Case ACHRON_SHEL_PESACH
            YomTovFormat = "àçøåï ùì ôñç"
        Case SHAVOUS_DAY1, SHAVOUS_DAY2
            YomTovFormat = "ùáåòåú"
        Case ROSH_HASHANAH_DAY1, ROSH_HASHANAH_DAY2
            YomTovFormat = "øàù äùðä"
        Case YOM_KIPPUR
            YomTovFormat = "éåí ëéôåø"
        Case SUKKOS_DAY1, SUKKOS_DAY2
            YomTovFormat = "ñåëåú"
        Case SHMEINI_ATZERES
            YomTovFormat = "ùîéðé òöøú"
        Case SIMCHAS_TORAH
            YomTovFormat = "ùîçú úåøä"
        Case CHOL_HAMOED_PESACH_DAY1 To CHOL_HAMOED_PESACH_DAY5
            YomTovFormat = "çåì äîåòã ôñç"
        Case CHOL_HAMOED_SUKKOS_DAY1 To CHOL_HAMOED_SUKKOS_DAY5
            YomTovFormat = "çåì äîåòã ñåëåú"
        Case HOSHANA_RABBAH
            YomTovFormat = "äåùòðà øáä"
        Case PESACH_SHEINI
            YomTovFormat = "ôñç ùðé"
        Case LAG_BAOMER
            YomTovFormat = "ìØâ áòåîø"
        Case TU_BAV
            YomTovFormat = "èØå áàá"
        Case CHANUKAH_DAY1 To CHANUKAH_DAY8
            YomTovFormat = "çðåëä"
        Case TU_BISHVAT
            YomTovFormat = "èØå áùáè"
        Case PURIM_KATAN
            YomTovFormat = "ôåøéí ÷èï"
        Case SHUSHAN_PURIM_KATAN
            YomTovFormat = "ùåùï ôåøéí ÷èï"
        Case PURIM
            YomTovFormat = "ôåøéí"
        Case SHUSHAN_PURIM
            YomTovFormat = "ùåùï ôåøéí"
        Case SHIVA_ASAR_BTAAMUZ
            YomTovFormat = "ùáòä òùø áúîåæ"
        Case TISHA_BAV
            YomTovFormat = "èØá"
        Case TZOM_GEDALIA
            YomTovFormat = "öåí âãìéä"
        Case ASARAH_BTEVES
            YomTovFormat = "òùøä áèáú"
        Case TAANIS_ESTER
            YomTovFormat = "úòðéú àñúø"
        Case EREV_PESACH
            YomTovFormat = "òøá ôñç"
        Case EREV_SHAVOUS
            YomTovFormat = "òøá ùáåòåú"
        Case EREV_ROSH_HASHANAH
            YomTovFormat = "òøá øàù äùðä"
        Case EREV_YOM_KIPPUR
            YomTovFormat = "òøá éåí ëéôåø"
        Case EREV_SUKKOS
            YomTovFormat = "òøá ñåëåú"
        Case SHKALIM
            YomTovFormat = "ôøùú ù÷ìéí"
        Case ZACHOR
            YomTovFormat = "ôøùú æëåø"
        Case PARAH:
            YomTovFormat = "ôøùú ôøä"
        Case HACHODESH:
            YomTovFormat = "ôøùú äçåãù"
        Case ROSH_CHODESH:
            YomTovFormat = "øàù çåãù"
        Case MACHAR_CHODESH:
            YomTovFormat = "îçø çåãù"
        Case SHABBOS_MEVORCHIM:
            YomTovFormat = "ùáú îáøëéí"
        Case HAGADOL:
            YomTovFormat = "ùáú äâãåì"
        Case CHAZON:
            YomTovFormat = "ùáú çæåï"
        Case NACHAMU:
            YomTovFormat = "ùáú ðçîå"
        Case SHUVA:
            YomTovFormat = "ùáú ùåáä"
        Case SHIRA:
            YomTovFormat = "ùáú ùéøä"
        Case SHABBOS_CHOL_HAMOED:
            YomTovFormat = "ùáú çåì äîåòã"
        Case Else
            YomTovFormat = ""
    End Select
End Function

'convert avos int to char based representation
Function AvosFormat(ByVal avos As Integer) As String
    If hdateformat_ready = False Then init_hdateformat
    Select Case avos
        Case 1
            AvosFormat = "à"
        Case 2
            AvosFormat = "á"
        Case 3
            AvosFormat = "â"
        Case 4
            AvosFormat = "ã"
        Case 5
            AvosFormat = "ä"
        Case 6
            AvosFormat = "å"
        Case 12
            AvosFormat = "à-á"
        Case 34
            AvosFormat = "â-ã"
        Case 56
            AvosFormat = "ä-å"
        Case Else
            AvosFormat = ""
    End Select
End Function

'rounds seconds of a time to an added or substracted minute
Function tround(t As Date) As Date
    tround = IIf(second(t) > 29, DateAdd("n", 1, t), t)
End Function