ماژول تغییر تاریخ میلادی به هجری شمسی
این ماجول در چندین برنامه تست شده و جواب گرفته است شما هم می توانید از آن استفاده کنید.
(توجه داشته باشید که کدهای نوشته شده ، در اینجا از چپ به راست نمایش داده شده اند ولی با کپی آن در اکسس ، نمایش آن از چپ به راست خواهد شد)
در صورت استفاده از این ماجول ، فیلدهای از نوع تاریخ را باید از نوع Number تعریف کنید. توضیحات بیشتر جهت استفاده از ماجول ، درون خود ماجول نوشته شده است.
برای استفاده از این ماجول ، از دو خط پایین تر تا انتهای متن را در حافظه کپی کرده (Copy) و سپس در یک ماجول جدید در اکسس یا VB قرار دهید (Paste):
‘ 1- تعریف کنید Number(Long) است را بصورت Date فیلدهایی که نوع آنها
‘ ۲- این فیلدها را بصورت ۰۰/۰۰/۰۰ تنظیم کنید InputMask خاصیت
‘ بدلیل ۶ رقمی در نظر گرفتن فیلد تاریخ ، این توابع تا سال ۱۳۹۹ کارایی دارد
‘ …
‘ تاریخ جاری سیستم را به هجری شمسی تبدیل می کند Shamsi() تابع
‘ بکار ببرید Now() را می توانید در گزارشات بجای تابع Dat() تابع
‘ :برای جلوگیری از ورود تاریخ غلط به درون یک فیلد بترتیب زیر عمل میکنید
‘ :بشکل زیر بکار ببرید ValidationRule را در خاصیت ValidDate() تابع
‘ ValidDate([نام فیلد])=True
‘ …
‘*******************************************
Public FunctionRooz(F_Date As Long) As Byte
‘این تابع عدد مربوط به روز یک تاریخ را برمگرداند
Rooz = F_Date Mod 100
EndFunction
‘*******************************************
Function Mah(F_DateAs Long) As Byte
‘این تابع عدد مربوط به ماه یک تاریخ را برمگرداند
Mah = Int((F_Date Mod 10000) / 100)
EndFunction
‘*******************************************
Public FunctionSal(F_Date As Long) As Byte
‘این تابع عدد مربوط به سال یک تاریخ را برمگرداند
Sal = Int(F_Date / 10000)
EndFunction
‘*******************************************
Public FunctionKabiseh(ByValOnlySal As Variant) As Byte
‘ورودی تابع عدد دورقمی است
‘این تابع کبیسه بودن سال را برمیگرداند
‘اگر سال کبیسه باشد عدد یک و درغیر اینصورت صفر را بر میگرداند
Kabiseh = 0
If OnlySal>= 75 Then
If (OnlySal – 75) Mod 4 = 0 Then
Kabiseh = 1
Exit Function
End If
ElseIfOnlySal<= 70 Then
If (70 – OnlySal) Mod 4 = 0 Then
Kabiseh = 1
ExitFunction
End If
End If
EndFunction
‘*******************************************
FunctionValidDate(F_Date As Long) As Boolean
Dim M, S, R As Byte
‘ این تابع اعتبار یک عدد ورودی را از نظر تاریخ هجری شمسی بررسی می کند
‘ را برمی گرداند False واگر نامعتبر باشد True اگر تاریخ معتبر باشد
ValidDate = True
S = Sal(F_Date)
M = Mah(F_Date)
R = Rooz(F_Date)
‘********
If F_Date< 100101 Then
ValidDate = False
Exit Function
End If
If M> 12 Or M = 0 Or R = 0 Then
ValidDate = False
Exit Function
EndIf
If R>MahDays(S, M) Then
ValidDate = False
ExitFunction
End If
EndFunction
‘*******************************************
Public FunctionAddDay(ByValF_Date As Long, ByVal add As Integer) As Long
Dim K, M, S, R, Days As Byte
R = Rooz(F_Date)
M = Mah(F_Date)
S = Sal(F_Date)
K = Kabiseh(S)
‘تبدیل روز به عدد ۱ جهت ادامه محاسبات و یا اتمام محاسبه
Days = MahDays(S, M)
If add>Days – R Then
add = add – (Days – R + 1)
R = 1
If M< 12 Then
M = M + 1
Else
M = 1
S = S + 1
End If
Else
R = R + add
add = 0
End If
While add> 0
K = Kabiseh(S) ‘کبیسه: ۱ و غیر کبیسه: ۰
Days = MahDays(S, M) ‘تعداد روزهای ماه فعلی
Select Case add
Case Is
R = R + add
add = 0
Case Days To IIf(K = 0, 365, 366) – 1
‘اگر تعداد روزهای افزودنی بیشتر از یک ماه و کمتر از یک سال باشد
add = add – Days
If M< 12 Then
M = M + 1
Else
S = S + 1
M = 1
End If
Case Else
‘اگر تعداد روزهای افزودنی بیشتر از یک سال باشد
S = S + 1
add = add – IIf(K = 0, 365, 366)
EndSelect
Wend
AddDay = (S * 10000) + (M * 100) + (R)
EndFunction
‘***********************************************
PublicFunction Shamsi() As Long
‘تاریخ جاری سیستم را به تاریخ هجری شمسی تبدیل می کند
Dim Shamsi_Mabna As Long
Dim Miladi_mabna As Date
Dim Dif AsLong
‘در اینجا ۸۰/۱۰/۱۱ با ۲۰۰۲/۰۱/۰۱ معادل قرارداده شده
Shamsi_Mabna = 791012
Miladi_mabna = #1/1/01#
Dif = DateDiff(“d”, Miladi_mabna, Date)
If Dif< 0 Then
MsgBox “تاریخ جاری سیستم شما نادرست است , آنرا اصلاح کنید.”
Else
Shamsi = AddDay(Shamsi_Mabna, Dif)
End If
EndFunction
‘***********************************************
Public FunctionDayWeek(F_Date As Long) As String
Dim a As String
Dim N As Byte
N = DayWeekNo(F_Date)
Select Case N
Case 0
a = “شنبه”
Case 1
a = “یکشنبه”
Case 2
a = “دوشنبه”
Case 3
a = “سهشنبه”
Case 4
a = “چهارشنبه”
Case 5
a = “پنجشنبه”
Case 6
a = “جمعه”
EndSelect
DayWeek = a
EndFunction
‘***********************************************
PublicFunction Dat()
Dim D As Long
D = Shamsi
Dat = DayWeek(D) & ” 13″ &Sal(D) & “/” &Mah(D) & “/” &Rooz(D)
EndFunction
‘***********************************************
PublicFunction Diff(ByValFromDate As Long, ByValTo_Date As Long) As Long
‘این تابع تعداد روزهای بین دو تاریخ را ارائه می کند
Dim Tmp As Long
Dim S1, M1, r1, S2, m2, r2 As Integer
Dim Sumation As Single
Dim Flag AsBoolean
Flag = False
If FromDate = 0 Or IsNull(FromDate) = True Or To_Date = 0 Or IsNull(To_Date) = True Then
Diff = 0
Exit Function
EndIf
If FromDate>To_Date Then
‘اگر تاریخ شروع از تاریخ پایان بزرگتر باشد آنها موقتا جابجا می شوند
Flag = True
Tmp = FromDate
FromDate = To_Date
To_Date = Tmp
End If
r1 = Rooz(FromDate)
M1 = Mah(FromDate)
S1 = Sal(FromDate)
r2 = Rooz(To_Date)
m2 = Mah(To_Date)
S2 = Sal(To_Date)
Sumation = 0
Do While S1
If Kabiseh((S1)) = 1 Then
If M1 = 12 And r1 = 30Then
Sumation = Sumation + 365
r1 = 29
Else
Sumation = Sumation + 366
End If
Else
Sumation = Sumation + 365
End If
S1 = S1 + 1
Loop
Do While S1
Select Case M1
Case 1 To 6
If M1 = 6 And r1 = 31 Then
Sumation = Sumation + 30
r1 = 30
Else
Sumation = Sumation + 31
End If
M1 = M1 + 1
Case 7 To 11
If M1 = 11 And r1 = 30 And Kabiseh(S1) = 0 Then
Sumation = Sumation + 29
r1 = 29
Else
Sumation = Sumation + 30
End If
M1 = M1 + 1
Case 12
If Kabiseh(S1) = 1 Then
Sumation = Sumation + 30
Else
Sumation = Sumation + 29
End If
S1 = S1 + 1
M1 = 1
EndSelect
Loop
If M1 = m2 Then
Sumation = Sumation + (r2 – r1)
Else
Select Case M1
Case 1 To 6
Sumation = Sumation + (31 – r1) + r2
Case 7 To 11
Sumation = Sumation + (30 – r1) + r2
Case 12
IfKabiseh(S1) = 1 Then
Sumation = Sumation + (30 – r1) + r2
Else
Sumation = Sumation + (29 – r1) + r2
End If
End Select
End If
If Flag = True Then
Sumation = -Sumation
End If
Diff = Sumation
EndFunction
Public Function DayWeekNo(F_Date As Long) As String
‘این تابع یک تاریخ را دریافت کرده و مشخص می کند چه روزی از هفته است
‘اگر شنبه باشد عدد ۰
‘اگر ۱شنبه باشد عدد ۱
‘……
‘اگر جمعه باشد عدد ۶
Dim day AsString
Dim Shmsi_Mabna As Long
Dim Dif As Long
‘مبنا ۸۰/۱۰/۱۱
Shmsi_Mabna = 801011
Dif = Diff(Shmsi_Mabna, F_Date)
IfShmsi_Mabna>F_Date Then
Dif = -Dif
End If
‘با توجه به اینکه ۸۰/۱۰/۱۱ ۳شنبه است محاسبه میشود day متغیر
day = (Dif + 3) Mod 7
If day< 0 Then
DayWeekNo = day + 7
Else
DayWeekNo = day
End If
EndFunction
Function MahName(ByValMah_no As Byte) As String
SelectCase 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 = “اسفند”
End Select
End Function
Function SalMah(ByValF_Date AsLong) As Integer
‘چهار رقم اول تاریخ که معرف سال و ماه است را برمی گرداند
SalMah = Val(Left$(F_Date, 4))
End Function
FunctionMahDays(ByVal Sal As Byte, ByValMah As Byte) As Byte
‘این تابع تعداد روزهای یک ماه را برمی گرداند
Select Case Mah
Case 1 To 6
MahDays = 31
Case 7 To 11
MahDays = 30
Case 12
If Kabiseh(Sal) = 1 Then
MahDays = 30
Else
MahDays = 29
End If
End Select
EndFunction
Function Make_Date(ByValF_Date As Long) As String
‘یک تاریخ را بصورت یک رشته ۱۰ رقمی با ذکر چهار رقم برای سال ارائه می کند
Dim D AsString
D = Trim(Str(F_Date))
If IsNull(F_Date) = True Or F_Date = 0Then
Make_Date = “”
Else
Make_Date = “13” &Mid(D, 1, 2) & “/” &Mid(D, 3, 2) & “/” &Mid(D, 5, 2)
End If
EndFunction
Function NextMah(ByValSal_Mah As Integer) As Integer
If (Sal_Mah Mod 100) = 12 Then
NextMah = (Int(Sal_Mah / 100) + 1) * 100 + 1
Else
NextMah = Sal_Mah + 1
End If
End Function
FunctionPreviousMah(ByValSal_Mah As Integer) As Integer
If (Sal_Mah Mod 100) = 1Then
PreviousMah = (Int(Sal_Mah / 100) – 1) * 100 + 12
Else
PreviousMah = Sal_Mah – 1
End If
End Function
Function SubtractDay(ByValF_Date As Long, ByVal Subtract As Long) As Long
‘به تعداد روز معینی از یک تاریخ کم کرده و تاریخ حاصله را ارائه میکند
Dim K, M, S, R, Days AsByte
R = Rooz(F_Date)
M = Mah(F_Date)
S = Sal(F_Date)
K = Kabiseh(S)
‘تبدیل روز به عدد ۱ جهت ادامه محاسبات و یا اتمام محاسبه
IfSubtract>= R – 1 Then
Subtract = Subtract – (R – 1)
R = 1
Else
R = R – Subtract
Subtract = 0
End If
While Subtract> 0
K = Kabiseh(S – 1) ‘کبیسه: ۱ و غیر کبیسه: ۰
Days = MahDays(IIf(M>= 2, S, S – 1), IIf(M>= 2, M – 1, 12)) ‘تعداد روزهای ماه قبلی
Select CaseSubtract
Case Is
R = Days – Subtract + 1
Subtract = 0
If M>= 2 Then
M = M – 1
Else
S = S – 1
M = 12
End If
Case Days To IIf(K = 0, 365, 366) – 1
‘اگر تعداد روزهای کاهش بیشتر از یک ماه و کمتر از یک سال باشد
Subtract = Subtract – Days
If M>= 2 Then
M = M – 1
Else
S = S – 1
M = 12
End If
Case Else
‘اگر تعداد روزهای کاهش بیشتر از یک سال باشد
S = S – 1
Subtract = Subtract – IIf(K = 0, 365, 366)
EndSelect
Wend
SubtractDay = (S * 10000) + (M * 100) + (R)
EndFunction