Option Explicit

' ============================================================
' تقویم هجری شمسی برای LibreOffice Basic / Calc
'
' بر پایهٔ الگوریتم جلالی Borkowski / jalaali-js
'
' محدودهٔ الگوریتم:
' 61- تا 3177 هجری شمسی
'
' تاریخ به صورت عددی ذخیره می‌شود:
' YYYYMMDD
'
' مثال:
' 14031230 = 30 اسفند 1403
' ============================================================


' ------------------------------------------------------------
' این متغیر مقدار کلیک‌شده در فرم تقویم را به‌صورت سراسری
' در خودش ذخیره می‌کند.
' ------------------------------------------------------------
Public strDate As String


' ============================================================
' استخراج اجزای تاریخ
' ============================================================

Public Function Rooz(ByVal F_Date As Long) As Byte
    ' روز تاریخ YYYYMMDD
    Rooz = F_Date Mod 100
End Function


Public Function Mah(ByVal F_Date As Long) As Byte
    ' ماه تاریخ YYYYMMDD
    Mah = (F_Date Mod 10000) \ 100
End Function


Public Function Sal(ByVal F_Date As Long) As Integer
    ' سال تاریخ YYYYMMDD
    Sal = F_Date \ 10000
End Function


' ============================================================
' الگوریتم اصلی تقویم جلالی
'
' JalCal:
' Leap  = فاصلهٔ سال جاری از آخرین سال کبیسه
'         اگر Leap = 0 باشد، سال کبیسه است.
'
' Gy    = سال میلادی آغاز سال جلالی
' March = روز ماه مارس که اول فروردین در آن واقع می‌شود.
' ============================================================

Private Sub JalCal( _
    ByVal Jy As Long, _
    ByRef Leap As Integer, _
    ByRef Gy As Long, _
    ByRef March As Long)

    Dim Breaks
    Dim Bl As Long
    Dim I As Long
    Dim Jp As Long
    Dim Jm As Long
    Dim Jump As Long
    Dim N As Long
    Dim LeapJ As Long
    Dim LeapG As Long

    Breaks = Array( _
        -61, 9, 38, 199, 426, 686, 756, 818, _
        1111, 1181, 1210, 1635, 2060, 2097, _
        2192, 2262, 2324, 2394, 2456, 3178)

    Bl = UBound(Breaks) + 1

    If Jy < Breaks(0) Or Jy >= Breaks(Bl - 1) Then
        Err.Raise 5, "JalCal", _
            "سال هجری شمسی خارج از محدودهٔ الگوریتم است: " & Jy
        Exit Sub
    End If

    Gy = Jy + 621
    LeapJ = -14
    Jp = Breaks(0)
    Jump = 0

    ' یافتن محدودهٔ مربوط به سال مورد نظر
    For I = 1 To Bl - 1
        Jm = Breaks(I)
        Jump = Jm - Jp

        If Jy < Jm Then
            Exit For
        End If

        LeapJ = LeapJ + (Jump \ 33) * 8 _
                       + ((Jump Mod 33) \ 4)

        Jp = Jm
    Next I

    N = Jy - Jp

    ' تعداد سال‌های کبیسه تا ابتدای سال مورد نظر
    LeapJ = LeapJ + (N \ 33) * 8 _
                   + (((N Mod 33) + 3) \ 4)

    If (Jump Mod 33) = 4 And (Jump - N) = 4 Then
        LeapJ = LeapJ + 1
    End If

    ' تعداد سال‌های کبیسهٔ میلادی
    LeapG = (Gy \ 4) _
          - ((((Gy \ 100) + 1) * 3) \ 4) _
          - 150

    ' روز مارس که اول فروردین در آن واقع می‌شود
    March = 20 + LeapJ - LeapG

    ' تعیین فاصلهٔ سال جاری از آخرین سال کبیسه
    If (Jump - N) < 6 Then
        N = N - Jump + ((Jump + 4) \ 33) * 33
    End If

    Leap = ((N + 1) Mod 33 - 1) Mod 4

    If Leap = -1 Then
        Leap = 4
    End If

End Sub


' ============================================================
' تشخیص کبیسه بودن سال
' ============================================================

Public Function Kabiseh(ByVal OnlySal As Integer) As Byte

    Dim Leap As Integer
    Dim Gy As Long
    Dim March As Long

    JalCal CLng(OnlySal), Leap, Gy, March

    If Leap = 0 Then
        Kabiseh = 1
    Else
        Kabiseh = 0
    End If

End Function


' ============================================================
' تعداد روزهای ماه
' ============================================================

Public Function MahDays( _
    ByVal YearNo As Integer, _
    ByVal MonthNo As Byte) As Byte

    Select Case MonthNo

        Case 1 To 6
            MahDays = 31

        Case 7 To 11
            MahDays = 30

        Case 12
            If Kabiseh(YearNo) = 1 Then
                MahDays = 30
            Else
                MahDays = 29
            End If

        Case Else
            MahDays = 0

    End Select

End Function


' ============================================================
' اعتبارسنجی تاریخ شمسی
' ============================================================

Public Function ValidDate(ByVal F_Date As Long) As Boolean

    Dim Y As Long
    Dim M As Byte
    Dim D As Byte

    ValidDate = False

    If F_Date <= 0 Then Exit Function

    Y = Sal(F_Date)
    M = Mah(F_Date)
    D = Rooz(F_Date)

    ' الگوریتم جلالی مورد استفاده در این ماکرو
    ' برای سال‌های 61- تا 3177 معتبر است.
    If Y < 1 Or Y > 3177 Then Exit Function

    If M < 1 Or M > 12 Then Exit Function

    If D < 1 Or D > MahDays(Y, M) Then Exit Function

    ValidDate = True

End Function


' ============================================================
' تبدیل تاریخ شمسی به تاریخ میلادی
' ============================================================

Public Function shamsibemiladi( _
    ByVal F_Date As Long) As Date

    Dim Y As Long
    Dim M As Byte
    Dim D As Byte

    Dim Leap As Integer
    Dim Gy As Long
    Dim March As Long

    Dim FirstDay As Date
    Dim Offset As Long

    If Not ValidDate(F_Date) Then
        shamsibemiladi = 0
        Exit Function
    End If

    Y = Sal(F_Date)
    M = Mah(F_Date)
    D = Rooz(F_Date)

    JalCal Y, Leap, Gy, March

    ' اول فروردین
    FirstDay = DateSerial(Gy, 3, March)

    ' فاصلهٔ روز اول سال تا تاریخ مورد نظر
    If M <= 6 Then
        Offset = (M - 1) * 31 + (D - 1)
    Else
        Offset = 186 + (M - 7) * 30 + (D - 1)
    End If

    shamsibemiladi = FirstDay + Offset

End Function


' ============================================================
' تبدیل تاریخ میلادی به تاریخ شمسی
' ============================================================

Public Function miladibeshamsi( _
    ByVal M_Date As Variant) As Long

    Dim Gy As Long
    Dim Gm As Long
    Dim Gd As Long

    Dim Jy As Long
    Dim Leap As Integer
    Dim JGy As Long
    Dim March As Long

    Dim FirstDay As Date
    Dim GDate As Date
    Dim K As Long
    Dim Jm As Long
    Dim Jd As Long

    miladibeshamsi = 0

    ' ------------------------------------------------------------
    ' تشخیص نوع ورودی
    '
    ' اگر مقدار بزرگ باشد، آن را YYYYMMDD در نظر می‌گیریم.
    ' مثلاً:
    ' 20260824
    '
    ' اگر مقدار کوچک‌تر باشد، آن را شمارهٔ سریالی Date
    ' در LibreOffice در نظر می‌گیریم.
    ' ------------------------------------------------------------

    If CDbl(M_Date) >= 1000000 Then

        ' ورودی به صورت YYYYMMDD
        Gy = CLng(M_Date) \ 10000
        Gm = (CLng(M_Date) Mod 10000) \ 100
        Gd = CLng(M_Date) Mod 100

        ' بررسی اولیهٔ تاریخ
        If Gy < 1 Or Gm < 1 Or Gm > 12 Or Gd < 1 Or Gd > 31 Then
            Exit Function
        End If

        GDate = DateSerial(Gy, Gm, Gd)

        ' جلوگیری از پذیرش تاریخ‌های غیرواقعی
        If Year(GDate) <> Gy _
            Or Month(GDate) <> Gm _
            Or Day(GDate) <> Gd Then
            Exit Function
        End If

    Else

        ' ورودی یک Date واقعی است؛
        ' مثلاً Date یا حاصل DateSerial
        GDate = CDate(M_Date)

        Gy = Year(GDate)
        Gm = Month(GDate)
        Gd = Day(GDate)

    End If

    ' سال جلالی تقریبی
    Jy = Gy - 621

    ' بررسی محدودهٔ الگوریتم
    If Jy < -61 Or Jy >= 3178 Then
        Exit Function
    End If

    ' یافتن آغاز سال جلالی
    JalCal Jy, Leap, JGy, March

    FirstDay = DateSerial(JGy, 3, March)

    ' اگر تاریخ میلادی پیش از نوروز باشد،
    ' متعلق به سال جلالی قبلی است.
    If GDate < FirstDay Then

        Jy = Jy - 1

        If Jy < -61 Or Jy >= 3178 Then
            Exit Function
        End If

        JalCal Jy, Leap, JGy, March

        FirstDay = DateSerial(JGy, 3, March)

    End If

    ' فاصلهٔ تاریخ از اول فروردین
    K = DateDiff("d", FirstDay, GDate)

    If K <= 185 Then

        Jm = 1 + (K \ 31)
        Jd = (K Mod 31) + 1

    Else

        K = K - 186
        Jm = 7 + (K \ 30)
        Jd = (K Mod 30) + 1

    End If

    ' خروجی به صورت YYYYMMDD
    miladibeshamsi = Jy * 10000 + Jm * 100 + Jd

End Function


' ============================================================
' تاریخ شمسی جاری سیستم
' ============================================================

Public Function Shamsi() As Long

    Shamsi = miladibeshamsi(Date)

End Function


' ============================================================
' افزودن روز
'
' برخلاف نسخهٔ قدیمی، دیگر نیازی به پیمایش ماه‌به‌ماه ندارد.
' تاریخ شمسی ابتدا به میلادی تبدیل می‌شود، تعداد روز اضافه می‌شود
' و سپس دوباره به شمسی تبدیل می‌شود.
' ============================================================

Public Function AddDay( _
    ByVal F_Date As Long, _
    ByVal Add As Long) As Long

    Dim GDate As Date

    If Not ValidDate(F_Date) Then
        MsgBox "تاریخ ورودی نامعتبر است."
        AddDay = 0
        Exit Function
    End If

    GDate = shamsibemiladi(F_Date)

    GDate = GDate + Add

    AddDay = miladibeshamsi(GDate)

End Function


' ============================================================
' کم کردن روز
' ============================================================

Public Function SubtractDay( _
    ByVal F_Date As Long, _
    ByVal Subtract As Long) As Long

    Dim GDate As Date

    If Not ValidDate(F_Date) Then
        MsgBox "تاریخ ورودی نامعتبر است."
        SubtractDay = 0
        Exit Function
    End If

    GDate = shamsibemiladi(F_Date)

    GDate = GDate - Subtract

    SubtractDay = miladibeshamsi(GDate)

End Function


' ============================================================
' فاصلهٔ دو تاریخ
'
' نتیجه:
' Diff(A,B) = تعداد روزهای B نسبت به A
'
' بنابراین:
' Diff(14030101, 14030102) = 1
' Diff(14030102, 14030101) = -1
' ============================================================

Public Function Diff( _
    ByVal FromDate As Long, _
    ByVal To_Date As Long) As Long

    Dim G1 As Date
    Dim G2 As Date

    If Not ValidDate(FromDate) Then
        Diff = 0
        Exit Function
    End If

    If Not ValidDate(To_Date) Then
        Diff = 0
        Exit Function
    End If

    G1 = shamsibemiladi(FromDate)
    G2 = shamsibemiladi(To_Date)

    Diff = DateDiff("d", G1, G2)

End Function


' ============================================================
' شمارهٔ روز هفته
'
' خروجی:
' 0 = شنبه
' 1 = یکشنبه
' 2 = دوشنبه
' 3 = سه‌شنبه
' 4 = چهارشنبه
' 5 = پنج‌شنبه
' 6 = جمعه
' ============================================================

Public Function DayWeekNo(ByVal F_Date As Long) As Byte

    Dim GDate As Date
    Dim W As Integer

    If Not ValidDate(F_Date) Then
        DayWeekNo = 0
        Exit Function
    End If

    GDate = shamsibemiladi(F_Date)

    ' با FirstDayOfWeek = 7، شنبه شمارهٔ 1 می‌شود.
    W = WeekDay(GDate, 7)

    DayWeekNo = W - 1

End Function


' ============================================================
' نام روز هفته
' ============================================================

Public Function DayWeek(ByVal F_Date As Long) As String

    Select Case DayWeekNo(F_Date)

        Case 0
            DayWeek = "شنبه"

        Case 1
            DayWeek = "یکشنبه"

        Case 2
            DayWeek = "دوشنبه"

        Case 3
            DayWeek = "سه‌شنبه"

        Case 4
            DayWeek = "چهارشنبه"

        Case 5
            DayWeek = "پنج‌شنبه"

        Case 6
            DayWeek = "جمعه"

        Case Else
            DayWeek = ""

    End Select

End Function


' ============================================================
' نام ماه
' ============================================================

Public Function MahName(ByVal Mah_no As Byte) As String

    Select Case Mah_no

        Case 1
            MahName = "فروردین"

        Case 2
            MahName = "اردیبهشت"

        Case 3
            MahName = "خرداد"

        Case 4
            MahName = "تیر"

        Case 5
            MahName = "مرداد"

        Case 6
            MahName = "شهریور"

        Case 7
            MahName = "مهر"

        Case 8
            MahName = "آبان"

        Case 9
            MahName = "آذر"

        Case 10
            MahName = "دی"

        Case 11
            MahName = "بهمن"

        Case 12
            MahName = "اسفند"

        Case Else
            MahName = ""

    End Select

End Function


' ============================================================
' تاریخ جاری همراه با روز هفته
' ============================================================

Public Function Dat() As String

    Dim D As Long

    D = Shamsi

    If D = 0 Then
        Dat = ""
        Exit Function
    End If

    Dat = DayWeek(D) & " " & _
          Sal(D) & "/" & _
          Format(Mah(D), "00") & "/" & _
          Format(Rooz(D), "00")

End Function


' ============================================================
' قالب YYYY/MM/DD
' ============================================================

Public Function Make_Date(ByVal F_Date As Long) As String

    If Not ValidDate(F_Date) Then
        Make_Date = ""
        Exit Function
    End If

    Make_Date = Format(Sal(F_Date), "0000") & "/" & _
                Format(Mah(F_Date), "00") & "/" & _
                Format(Rooz(F_Date), "00")

End Function


' ============================================================
' سال + ماه
' مثال:
' 1403/07/15 -> 140307
' ============================================================

Public Function SalMah(ByVal F_Date As Long) As Long

    If Not ValidDate(F_Date) Then
        SalMah = 0
        Exit Function
    End If

    SalMah = Sal(F_Date) * 100 + Mah(F_Date)

End Function


' ============================================================
' ماه بعد
' ورودی: YYYYMM
' ============================================================

Public Function NextMah(ByVal Sal_Mah As Long) As Long

    Dim Y As Long
    Dim M As Long

    Y = Sal_Mah \ 100
    M = Sal_Mah Mod 100

    If M < 1 Or M > 12 Then
        NextMah = 0
        Exit Function
    End If

    If M = 12 Then
        NextMah = (Y + 1) * 100 + 1
    Else
        NextMah = Y * 100 + M + 1
    End If

End Function


' ============================================================
' ماه قبل
' ورودی: YYYYMM
' ============================================================

Public Function PreviousMah(ByVal Sal_Mah As Long) As Long

    Dim Y As Long
    Dim M As Long

    Y = Sal_Mah \ 100
    M = Sal_Mah Mod 100

    If M < 1 Or M > 12 Then
        PreviousMah = 0
        Exit Function
    End If

    If M = 1 Then
        PreviousMah = (Y - 1) * 100 + 12
    Else
        PreviousMah = Y * 100 + M - 1
    End If

End Function


' ============================================================
' روز هفتهٔ نخستین روز ماه
'
' مثال:
' Firstday(1403, 1)
'
' خروجی:
' 0 = شنبه
' ...
' 6 = جمعه
' ============================================================

Public Function Firstday( _
    ByVal YearNo As Integer, _
    ByVal MonthNo As Byte) As Long

    Dim FDate As Long

    FDate = CLng(YearNo) * 10000 _
          + CLng(MonthNo) * 100 _
          + 1

    If Not ValidDate(FDate) Then
        Firstday = 0
        Exit Function
    End If

    Firstday = DayWeekNo(FDate)

End Function