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

[mazoolagh]

دلیل ساخت این آموزش در تاپیک زیر اومده (پست 8):
سوال: فیلد محاسباتی در After Update (https://barnamenevis.org/showthread.php?593312-%D9%81%DB%8C%D9%84%D8%AF-%D9%85%D8%AD%D8%A7%D8%B3%D8%A8%D8%A7%D8%AA%DB%8C-%D8%AF%D8%B1-After-Update)

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

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

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


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


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


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

[mazoolagh]

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

[mazoolagh]

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

[mazoolagh]

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

[mazoolagh]

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

[mazoolagh]

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

[mazoolagh]

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

[mazoolagh]

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 میپردازیم.

[mazoolagh]

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

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

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

[mazoolagh]

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

[mazoolagh]

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

[mazoolagh]

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