ساخت یک کلاس و توابع مورد نیاز برای کار تاریخ ایرانی Persian Date Class and Functions

دلیل ساخت این آموزش در تاپیک زیر اومده (پست 8):
سوال: فیلد محاسباتی در After Update

و بخشی از توضیحات رو در پست شماره 10 همون تاپیک میتونین بخونین.

کدهای این تاپیک ساده شده یک مجموعه نسبتا سنگین و پیچیده کدهای یک کلاس و یک helper بوده
که:

1. بخشهای زمان و محاسبات روی اونها کلا کنار گذاشته شده
2. روش کبیسه گیری و شمارش روزهای سال کلا از محاسبه به کار با دیتا پیش محاسبه شده تغییر داده شده (برای سادگی و همچنین عدم نیاز در برنامه های متعارف و غیرعلمی)
3. محدوده مجاز تاریخ از 1 فروردین 1300 تا 20 اسفند 1420 تعریف شده (که برای کاربردهای عادی کاملا پاسخگو هست)،
4. با این وجود دست کاربر برای تغییر این بازه از 1 فروردین 1 تا 30 اسفند 9377 باز هست (فقط با ویرایش چند ثابت و یک array بدون تغییر در کدها)

چیزهایی که باید درنظر داشته باشین:

1. تاریخ، به طور کلی و بودن توجه به اینکه ایرانی خورشیدی یا گرگورین یا ماهشمار چینی و ... باشه همیشه یک شماره است (چون همه عملیات روی تاریخ باید با شماره ها انجام بشه) اینجا هم همه در توابع (بدون استثناء) چه خود تاریخ و چه اجزای اون (روز ماه سال) به شکل long تعریف شدن.
2. فرمت هایی مانند YYYY/MM/DD فقط برای نمایش هست (گزارش و فرم و ...) و نه محاسبه! پس اگر دیتا شما string و فرمت بندی شده است، باید اون رو به شکل صحیح به توابع پاس کنین (long YYYYMMDD).
3. فرصت کنم بعد از تمام شدن تاپیک در مورد اینکه چجوری تابعی بنویسیم که با همه مقادیر پاس شده (string/formatted string/long number) درست کار کنه و خروجی رو هم به همون شکل دریافتی بده.
4. مجموعه توابع مستقل و کلا همه کد مورد نیاز در یک module به اسم PersianDateHelper آمده، پس اگر تاریخ ایرانی رو بسادگی با یک مقدار long نشون میدین فقط افزودن همین ماجول به برنامه تون کافی هست.
5. یک calss module هم هست به اسم PersianDate که تاریخ ایرانی رو بعنوان object تعریف میکنه و متدها و پراپرتی های اون وابسته به PersianDateHelper هست.

در پست های بعدی فهرست توابع PersianDateHelper و همچنین متدها و پراپرتی های PersianDate رو میارم.

declaration / initialize

Option Compare Database

Option Explicit



Public Const MinYear As Long = 1300

Public Const MaxYear As Long = 1420

Public Const MinPrDate As Long = 13000101

Public Const MaxPrDate As Long = 14201230

Public Const MinGrDate As Date = #3/21/1921#    ' Persian 1300/01/01

Public Const MaxGrDate As Date = #3/20/2042#    ' Persian 1420/12/30



Public LeapYears

Public MonthNames

Public WeekDayNames



Public Type DateSpan

    Year As Long

    Month As Long

    Day As Long

    TotalDays As Long

    Sign As Long

End Type



Public Enum WeekRule

    FirstDay = 1

    FirstSaturDay = 2

End Enum

Public Sub InitializeData()

    If IsInitialized Then Exit Sub

    

    Calendar = vbCalGreg

    WeekDayNames = Array("", "شنبه", "یکشنبه", "دوشنبه", "سه‌شنبه", "چهارشنبه", "پنج‌شنبه", "آدینه")

    MonthNames = Array("", "فروردین", "اردیبهشت", "خرداد", "تیر", "امرداد", "شهریور", "مهر", "آبان", "آذر", "دی", "بهمن", "اسفند")

    Dim ly: ly = Array(0, 4, 9, 13, 17, 21, 25, 29, 33, 37, 42, 46, 50, 54, 58, 62, 66, 70, 75, 79, 83, 87, 91, 95, 99, 103, 108, 112, 116, 120)



ReDim LeapYears(MinYear To MaxYear)

    Dim i As Integer

    For i = MinYear To MaxYear

        LeapYears(i) = False

    Next i

    For i = LBound(ly) To UBound(ly)

        LeapYears(ly(i) + MinYear) = True

    Next i

End Sub



Public Function IsInitialized() As Boolean

    IsInitialized = (VarType(MonthNames) > (vbEmpty + vbNull))

End Function

validation

Public Function IsValidYear(YYYY As Long) As Boolean

    IsValidYear = (YYYY >= MinYear And YYYY <= MaxYear)

End Function





Public Function IsValidMonth(MM As Long) As Boolean

    IsValidMonth = (MM > 0 And MM < 13)

End Function





Public Function IsValidDateParts(YYYY As Long, MM As Long, DD As Long) As Boolean

    IsValidDateParts = ( _

        IsValidYear(YYYY) And _

        IsValidMonth(MM) And _

        DD > 0 And _

        DD <= GetDaysInMonth(YYYY, MM))

End Function





Public Function IsValidGregorianDate(gDate As Date) As Boolean

    IsValidGregorianDate = (gDate >= MinGrDate Or gDate <= MaxGrDate)

End Function





Public Sub ValidateYear(YYYY As Long)

    If Not IsValidYear(YYYY) Then

        Err.Raise _

            Number:=1001, _

            Description:="Invalid value for Year: " & YYYY & vbCrLf & _

            "Valid range from " & MinYear & " to " & MaxYear

    End If

End Sub

            

Public Sub ValidateMonth(MM As Long)

    If Not IsValidMonth(MM) Then

        Err.Raise _

            Number:=1002, _

            Description:="Invalid value for Month: " & MM & vbCrLf & _

            "Valid range of 1 to 12"

    End If

End Sub





Public Sub ValidateDateValue(pdate As Long)

    Dim pYear As Long, pMonth As Long, pDay As Long

    pDay = GetDay(pdate)

    pMonth = GetMonth(pdate)

    pYear = GetYear(pdate)

    ValidateDateParts pYear, pMonth, pDay

End Sub





Public Sub ValidateDateParts(YYYY As Long, MM As Long, DD As Long)

    ValidateYear YYYY

    ValidateMonth MM

    If DD < 1 Or DD > GetDaysInMonth(YYYY, MM) Then

        Err.Raise _

            Number:=1003, _

            Description:="Invalid value for DayOfMonth: " & MM & "/" & DD

    End If

End Sub





Public Sub ValidateGregorianDate(gDate As Date)

    If Not IsValidGregorianDate(gDate) Then

        Err.Raise 1004, , "Invalid Gregorian date : " & gDate _

        & vbCrLf & "Min= " & MinGrDate _

        & vbCrLf & "Max= " & MaxGrDate

    End If

End Sub

Persian date creation

Public Function FromDateValue(pDate As Long) As Long

    Dim pYear As Long, pMonth As Long, pDay As Long

    pYear = GetYear(pDate)

    pMonth = GetMonth(pDate)

    pDay = GetDay(pDate)

    FromDateValue = FromDateParts(pYear, pMonth, pDay)

End Function





Public Function FromDateParts(Year As Long, Month As Long, Day As Long) As Long

    ValidateDateParts Year, Month, Day

    FromDateParts = Year * 10000 + Month * 100 + Day

End Function





Public Function FromGregorian(gDate As Date) As Long

    FromGregorian = Gr2Pr(gDate)

End Function

date conversion

Public Function Gr2Pr(gDate As Date) As Long   ' Gregorian to Persian

    ValidateGregorianDate gDate

    Dim TotalDays As Long, pYear As Long, pMonth As Long, pDay As Long

    

    TotalDays = DateDiff("d", MinGrDate, gDate)

    pYear = MinYear

    

    Do Until TotalDays < GetDaysInYear(pYear)

        TotalDays = TotalDays - GetDaysInYear(pYear)

        pYear = pYear + 1

    Loop

    

    pMonth = 1

    Do Until TotalDays < GetDaysInMonth(pYear, pMonth)

        TotalDays = TotalDays - GetDaysInMonth(pYear, pMonth)

        pMonth = pMonth + 1

    Loop

        

    pDay = TotalDays + 1

    Gr2Pr = FromDateParts(pYear, pMonth, pDay)

End Function





Public Function Pr2Gr(pDate As Long) As Date     ' Persian to Gregorian

    ValidateDateValue pDate

    Dim TotalDays As Long, pYear As Long

    pYear = GetYear(pDate)

    TotalDays = GetDayOfYear(pDate)





    Dim i As Long

    For i = MinYear To pYear - 1

        TotalDays = TotalDays + GetDaysInYear(i)

    Next i

    

    Dim gDate As Date

    gDate = VBA.DateAdd("d", TotalDays - 1, MinGrDate)

    Pr2Gr = DateSerial(Year(gDate), Month(gDate), Day(gDate))

End Function

Persian date parts / properties

Public Function GetYear(pDate As Long) As Long

    GetYear = (pDate \ 10000)

End Function





Public Function GetMonth(pDate As Long) As Long

    GetMonth = (pDate \ 100) Mod 100

End Function





Public Function GetDay(pDate As Long) As Long

    GetDay = pDate Mod 100

End Function





Public Function GetDaysInYear(YYYY As Long) As Long

    ValidateYear YYYY

    

    If IsLeapYear(YYYY) Then

        GetDaysInYear = 366

    Else

        GetDaysInYear = 365

    End If

End Function





Public Function GetDaysInMonth(YYYY As Long, MM As Long) As Long

    ValidateYear YYYY

    ValidateMonth MM

    

    Select Case MM

        Case 1 To 6

            GetDaysInMonth = 31

            Exit Function

        Case 7 To 11

            GetDaysInMonth = 30

            Exit Function

        Case 12

            If IsLeapYear(YYYY) Then

                GetDaysInMonth = 30

            Else

                GetDaysInMonth = 29

            End If

    End Select

End Function





Public Function GetDayOfYear(pDate As Long)

    Dim pYear As Long, pMonth As Long, pDay As Long

    pMonth = GetMonth(pDate)

    pDay = GetDay(pDate)

    

    If pMonth < 7 Then

        GetDayOfYear = (pMonth - 1) * 31 + pDay

    Else

        GetDayOfYear = 186 + (pMonth - 7) * 30 + pDay

    End If

End Function





Public Function GetMonthName(pDate As Long) As String

    InitializeData

    Dim pMonth As Long

    pMonth = GetMonth(pDate)

    GetMonthName = MonthNames(pMonth)

End Function





Public Function GetWeekDay(pDate As Long) As Long

    Dim gDate As Date

    gDate = Pr2Gr(pDate)

    GetWeekDay = VBA.WeekDay(gDate, vbSaturday)

End Function





Public Function GetWeekDayName(pDate As Long) As String

    InitializeData

    GetWeekDayName = WeekDayNames(GetWeekDay(pDate))

End Function





Public Function GetFirstShanbehOfYear(YYYY As Long) As Long

    ValidateYear YYYY

    GetFirstShanbehOfYear = GetFirstShanbehOfMonth(YYYY, 1)

End Function





Public Function GetFirstShanbehOfMonth(YYYY As Long, MM As Long) As Long

    Dim pDate As Long

    pDate = FromDateParts(YYYY, MM, 1)

    Do Until GetWeekDay(pDate) = 1

        pDate = pDate + 1

    Loop

    GetFirstShanbehOfMonth = pDate

End Function





Public Function GetWeekOfYear(pDate As Long, Optional Rule As WeekRule = WeekRule.FirstDay) As Long

    Dim days As Long

    days = GetDayOfYear(pDate)

    

    If Rule = WeekRule.FirstDay Then

        GetWeekOfYear = -Int(-days / 7)

    Else

        Dim k As Long

        k = GetFirstShanbehOfYear(GetYear(pDate)) Mod 100

        If days < k Then

            GetWeekOfYear = 0

        ElseIf days = k Then

            GetWeekOfYear = 1

        Else

            days = days - k + 1

            GetWeekOfYear = -Int(-days / 7)

        End If

    End If

End Function

Persian date calculations

Public Function AddYears(pDate As Long, Years As Long) As Long

' usage: use negative value for Years to Subtract

    Dim pYear As Long, pMonth As Long, pDay As Long

    pDay = GetDay(pDate)

    pMonth = GetMonth(pDate)

    pYear = GetYear(pDate) + Years

    

    If pMonth = 12 And pDay = 30 And (Not IsLeapYear(pYear)) Then

        pDay = 29

    End If

    AddYears = FromDateParts(pYear, pMonth, pDay)

End Function





Public Function AddMonths(pDate As Long, Months As Long) As Long

' usage: use negative value for Months to Subtract

    Dim pYear As Long, pMonth As Long, pDay As Long

    pDay = GetDay(pDate)

    pMonth = GetMonth(pDate)

    pYear = GetYear(pDate)

    ValidateDateParts pYear, pMonth, pDay

    

    pMonth = pMonth + (Months Mod 12)

    pYear = pYear + (Months \ 12) + (pMonth \ 12)

    pMonth = pMonth Mod 12

    

    If pMonth < 1 Then

        pMonth = pMonth + 12

        pYear = pYear - 1

    End If

    

    If pDay > GetDaysInMonth(pYear, pMonth) Then

      pDay = GetDaysInMonth(pYear, pMonth)

    End If





    AddMonths = FromDateParts(pYear, pMonth, pDay)

End Function





Public Function AddDays(pDate As Long, Days As Long) As Long

' usage: use negative value for Days to Subtract

    Dim pYear As Long, pMonth As Long, pDay As Long

    pDay = GetDay(pDate)

    pMonth = GetMonth(pDate)

    pYear = GetYear(pDate)

    ValidateDateParts pYear, pMonth, pDay

    

    Dim day_of_year As Long

    day_of_year = GetDayOfYear(pDate) + Days

    

    If day_of_year < 0 Then

        Do Until day_of_year > 0

            pYear = pYear - 1

            day_of_year = day_of_year + GetDaysInYear(pYear)

        Loop

    Else

        Do Until day_of_year <= GetDaysInYear(pYear)

            day_of_year = day_of_year - GetDaysInYear(pYear)

            pYear = pYear + 1

        Loop

    End If

    

    If day_of_year < 187 Then

        pMonth = (day_of_year \ 31) + 1

        pDay = day_of_year Mod 31

    Else

        pMonth = (day_of_year - 186) \ 30 + 7

        pDay = (day_of_year - 186) Mod 30

    End If

    

    If pDay = 0 Then

        pMonth = pMonth - 1

        If pMonth = 0 Then

            pMonth = 12

            pYear = pYear - 1

        End If

        pDay = GetDaysInMonth(pYear, pMonth)

    End If

    AddDays = FromDateParts(pYear, pMonth, pDay)

End Function





Public Function DiffDays(pDate1 As Long, pDate2 As Long) As Long

    ValidateDateValue pDate1

    ValidateDateValue pDate2

    

    Dim gDate1 As Date, gdate2 As Date

    gDate1 = Pr2Gr(pDate1)

    gdate2 = Pr2Gr(pDate2)

    DiffDays = DateDiff("d", gDate1, gdate2)

End Function





Public Function DiffWeeks(pDate1 As Long, pDate2 As Long) As Long

    ValidateDateValue pDate1

    ValidateDateValue pDate2

    

    Dim gDate1 As Date, gdate2 As Date

    gDate1 = Pr2Gr(pDate1)

    gdate2 = Pr2Gr(pDate2)

    DiffWeeks = DateDiff("ww", gDate1, gdate2, vbSaturday)

End Function





Public Function DiffDateSpan(pDate1 As Long, pDate2 As Long) As DateSpan

    Dim TotalDays As Long

    TotalDays = DiffDays(pDate1, pDate2)

    

    Dim YYYY As Long, MM As Long

    Dim dYears As Long, dMonths As Long, dDays As Long, xdays As Long

            

    If TotalDays < 0 Then

        MM = GetMonth(pDate2)

        YYYY = GetYear(pDate2)

    Else

        MM = GetMonth(pDate1)

        YYYY = GetYear(pDate1)

    End If





    dYears = 0

    dMonths = 0

    dDays = 0

    xdays = Abs(TotalDays)





    Do Until xdays < GetDaysInMonth(YYYY, MM)

        xdays = xdays - GetDaysInMonth(YYYY, MM)





        dMonths = dMonths + 1

        If dMonths = 12 Then

            dMonths = 0

            dYears = dYears + 1

        End If

        

        MM = MM + 1

        If MM > 12 Then

            MM = 1

            YYYY = YYYY + 1

        End If

    Loop





    DiffDateSpan.Year = dYears

    DiffDateSpan.Month = dMonths

    DiffDateSpan.Day = xdays

    DiffDateSpan.Sign = Sgn(TotalDays)

    DiffDateSpan.TotalDays = TotalDays

End Function

Persian date formatting and spell

Public Function FormatDate(pDate As Long) As String

    ValidateDateValue pDate

    FormatDate = Format(pDate, "0000/00/00")

End Function





Public Function SpellDate(pDate As Long) As String

    SpellDate = GetDay(pDate) & " " & GetMonthName(pDate) & " " & GetYear(pDate)

End Function





Public Function SpellFullDate(pDate As Long) As String

    SpellFullDate = GetWeekDayName(pDate) & " " & SpellDate(pDate)

End Function

تا اینجا توابع PersianDateHelper بود که بتنهایی میتونه استفاده بشه،
از پست بعدی به کلاس PersianDate میپردازیم.

این کلاس تاریخ ایرانی رو بصورت یک آبجکت تعریف میکنه
و تقریبا همه متدهای اون از PersianDateHelper گرفته شده.

پراپرتی های این کلاس read-only و مقداردهی تاریخ فقط بامتدهای زیر مجاز هست:
FromDateValue
FromDateParts
FromGregorian

مقدار پیش فرض آبجکت تاریخ MinPrDate هست که در PersianDateHelper تعریف شده.

declaration / initialize

Option Compare Database

Option Explicit





Private mYYYY As Long

Private mMM As Long

Private mDD As Long

Private mValue As Long

Private mgDate As Date





Private Sub Class_Initialize()

    InitializeData

    Value = MinPrDate

    Gregorian = MinGrDate

End Sub

properties

Public Property Get Year() As Long

    Year = mYYYY

End Property





Private Property Let Year(vlu As Long)

    mYYYY = vlu

End Property





Public Property Get Month() As Long

    Month = mMM

End Property





Private Property Let Month(vlu As Long)

    mMM = vlu

End Property





Public Property Get Day() As Long

    Day = mDD

End Property





Private Property Let Day(vlu As Long)

    mDD = vlu

End Property





Public Property Get Gregorian() As Date

    Gregorian = mgDate

End Property





Private Property Let Gregorian(vlu As Date)

    mgDate = DateSerial(VBA.Year(vlu), VBA.Month(vlu), VBA.Day(vlu))

End Property





Public Property Get Value() As Long

    Value = mValue

End Property





Private Property Let Value(vlu As Long)

    mValue = vlu

    mYYYY = PersianDateHelper.GetYear(vlu)

    mMM = PersianDateHelper.GetMonth(vlu)

    mDD = PersianDateHelper.GetDay(vlu)

End Property

methods

Public Sub FromDateValue(pDate As Long)

    Value = PersianDateHelper.FromDateValue(pDate)

    mgDate = Pr2Gr(Value)

End Sub





Public Sub FromDateParts(YYYY As Long, MM As Long, DD As Long)

    Value = PersianDateHelper.FromDateParts(YYYY, MM, DD)

    mgDate = Pr2Gr(Value)

End Sub





Public Sub FromGregorian(gDate As Date)

    Value = Gr2Pr(gDate)

    mgDate = DateSerial(VBA.Year(gDate), VBA.Month(gDate), VBA.Day(gDate))

End Sub





Public Sub AddYears(Years As Long)

' usage: use negative value for Years to Subtract

    Dim pDate As Long

    pDate = PersianDateHelper.AddYears(Value, Years)

    FromDateValue pDate

End Sub





Public Sub AddMonths(Months As Long)

' usage: use negative value for Months to Subtract

    

    Dim pDate As Long

    pDate = PersianDateHelper.AddMonths(Value, Months)

    FromDateValue pDate

End Sub





Public Sub AddDays(Days As Long)

' usage: use negative value for Days to Subtract

    

    Dim pDate As Long

    pDate = PersianDateHelper.AddDays(Value, Days)

    FromDateValue pDate

End Sub

Public Function GetDaysInYear() As Long

    GetDaysInYear = PersianDateHelper.GetDaysInYear(Year)

End Function





Public Function GetDaysInMonth() As Long

    GetDaysInMonth = PersianDateHelper.GetDaysInMonth(Year, Month)

End Function





Public Function GetDayOfYear()

    GetDayOfYear = PersianDateHelper.GetDayOfYear(Value)

End Function





Public Function GetWeekOfYear(Optional Rule As WeekRule = WeekRule.FirstDay) As Long

    GetWeekOfYear = PersianDateHelper.GetWeekOfYear(Value, Rule)

End Function





Public Function GetWeekDay() As Long

    GetWeekDay = VBA.WeekDay(Gregorian, vbSaturday)

End Function





Public Function GetWeekDayName() As String

    GetWeekDayName = WeekDayNames(GetWeekDay)

End Function





Public Function GetMonthName() As String

    GetMonthName = MonthNames(Month)

End Function





Public Function ToString() As String

    ToString = Format(Value, "0000/00/00")

End Function





Public Function SpellDate() As String

    SpellDate = PersianDateHelper.SpellDate(Value)

End Function





Public Function SpellFullDate() As String

    SpellFullDate = PersianDateHelper.SpellFullDate(Value)

End Function