' 1- تعريف كنيد Number(Long) است را بصورت Date فيلدهايي كه نوع آنها
' 2- اين فيلدها را بصورت 00/00/00 تنظيم كنيد InputMask خاصيت
' بدليل 6 رقمي در نظر گرفتن فيلد تاريخ ، اين توابع تا سال 1399 كارايي دارد
' ...
' تاريخ جاري سيستم را به هجري شمسي تبديل مي كند Shamsi() تابع
' بكار ببريد Now() را مي توانيد در گزارشات بجاي تابع Dat() تابع
' :براي جلوگيري از ورود تاريخ غلط به درون يك فيلد بترتيب زير عمل ميكنيد
' :بشكل زير بكار ببريد ValidationRule را در خاصيت ValidDate() تابع
' ValidDate([نام فيلد])=True
' ...
'*******************************************
Public Function Rooz(F_Date As Long) As Byte
'اين تابع عدد مربوط به روز يك تاريخ را برمگرداند
Rooz = F_Date Mod 100
End Function
'*******************************************
Function Mah(F_Date As Long) As Byte
'اين تابع عدد مربوط به ماه يك تاريخ را برمگرداند
Mah = Int((F_Date Mod 10000) / 100)
End Function
'*******************************************
Public Function Sal(F_Date As Long) As Byte
'اين تابع عدد مربوط به سال يك تاريخ را برمگرداند
Sal = Int(F_Date / 10000)
End Function
'*******************************************
Public Function Kabiseh(ByVal OnlySal As Variant) As Byte
'ورودي تابع عدد دورقمي است
'اين تابع كبيسه بودن سال را برميگرداند
'اگر سال كبيسه باشد عدد يك و درغير اينصورت صفر را بر ميگرداند
Kabiseh = 0
If OnlySal >= 75 Then
If (OnlySal - 75) Mod 4 = 0 Then
Kabiseh = 1
Exit Function
End If
ElseIf OnlySal <= 70 Then
If (70 - OnlySal) Mod 4 = 0 Then
Kabiseh = 1
Exit Function
End If
End If
End Function
'*******************************************
Function ValidDate(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
End If
If R > MahDays(S, M) Then
ValidDate = False
Exit Function
End If
End Function
'*******************************************
Public Function AddDay(ByVal F_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)
'تبديل روز به عدد 1 جهت ادامه محاسبات و يا اتمام محاسبه
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) 'كبيسه: 1 و غير كبيسه: 0
Days = MahDays(S, M) 'تعداد روزهاي ماه فعلي
Select Case add
Case Is < Days
'اگر تعداد روزهاي افزودني كمتر از يك ماه باشد
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)
End Select
Wend
AddDay = (S * 10000) + (M * 100) + (R)
End Function
'***********************************************
Public Function Shamsi() As Long
'تاريخ جاري سيستم را به تاريخ هجري شمسي تبديل مي كند
Dim Shamsi_Mabna As Long
Dim Miladi_mabna As Date
Dim Dif As Long
'در اينجا 80/10/11 با 2002/01/01 معادل قرارداده شده
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
End Function
'***********************************************
Public Function DayWeek(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 = "جمعه"
End Select
DayWeek = a
End Function
'***********************************************
Public Function Dat()
Dim D As Long
D = Shamsi
Dat = DayWeek(D) & " 13" & Sal(D) & "/" & Mah(D) & "/" & Rooz(D)
End Function
'***********************************************
Public Function Diff(ByVal FromDate As Long, ByVal To_Date As Long) As Long
'اين تابع تعداد روزهاي بين دو تاريخ را ارائه مي كند
Dim Tmp As Long
Dim S1, M1, r1, S2, m2, r2 As Integer
Dim Sumation As Single
Dim Flag As Boolean
Flag = False
If FromDate = 0 Or IsNull(FromDate) = True Or To_Date = 0 Or IsNull(To_Date) = True Then
Diff = 0
Exit Function
End If
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 < S2 - 1 Or (S1 = S2 - 1 And (M1 < m2 Or (M1 = m2 And r1 <= r2)))
'اگر يك سال يا بيشتر اختلاف بود
If Kabiseh((S1)) = 1 Then
If M1 = 12 And r1 = 30 Then
Sumation = Sumation + 365
r1 = 29
Else
Sumation = Sumation + 366
End If
Else
Sumation = Sumation + 365
End If
S1 = S1 + 1
Loop
Do While S1 < S2 Or M1 < m2 - 1 Or (M1 = m2 - 1 And r1 < r2)
'اگر يك ماه يا بيشتر اختلاف بود
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
End Select
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
If Kabiseh(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
End Function
Public Function DayWeekNo(F_Date As Long) As String
'اين تابع يك تاريخ را دريافت كرده و مشخص مي كند چه روزي از هفته است
'اگر شنبه باشد عدد 0
'اگر 1شنبه باشد عدد 1
'......
'اگر جمعه باشد عدد 6
Dim day As String
Dim Shmsi_Mabna As Long
Dim Dif As Long
'مبنا 80/10/11
Shmsi_Mabna = 801011
Dif = Diff(Shmsi_Mabna, F_Date)
If Shmsi_Mabna > F_Date Then
Dif = -Dif
End If
'با توجه به اينكه 80/10/11 3شنبه است محاسبه ميشود day متغير
day = (Dif + 3) Mod 7
If day < 0 Then
DayWeekNo = day + 7
Else
DayWeekNo = day
End If
End Function
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 = "اسفند"
End Select
End Function
Function SalMah(ByVal F_Date As Long) As Integer
'چهار رقم اول تاريخ كه معرف سال و ماه است را برمي گرداند
SalMah = Val(Left$(F_Date, 4))
End Function
Function MahDays(ByVal Sal As Byte, ByVal Mah 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
End Function
Function Make_Date(ByVal F_Date As Long) As String
'يك تاريخ را بصورت يك رشته 10 رقمي با ذكر چهار رقم براي سال ارائه مي كند
Dim D As String
D = Trim(Str(F_Date))
If IsNull(F_Date) = True Or F_Date = 0 Then
Make_Date = ""
Else
Make_Date = "13" & Mid(D, 1, 2) & "/" & Mid(D, 3, 2) & "/" & Mid(D, 5, 2)
End If
End Function
Function NextMah(ByVal Sal_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
Function PreviousMah(ByVal Sal_Mah As Integer) As Integer
If (Sal_Mah Mod 100) = 1 Then
PreviousMah = (Int(Sal_Mah / 100) - 1) * 100 + 12
Else
PreviousMah = Sal_Mah - 1
End If
End Function
Function SubtractDay(ByVal F_Date As Long, ByVal Subtract As Long) 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)
'تبديل روز به عدد 1 جهت ادامه محاسبات و يا اتمام محاسبه
If Subtract >= R - 1 Then
Subtract = Subtract - (R - 1)
R = 1
Else
R = R - Subtract
Subtract = 0
End If
While Subtract > 0
K = Kabiseh(S - 1) 'كبيسه: 1 و غير كبيسه: 0
Days = MahDays(IIf(M >= 2, S, S - 1), IIf(M >= 2, M - 1, 12)) 'تعداد روزهاي ماه قبلي
Select Case Subtract
Case Is < Days
'اگر تعداد روزهاي كاهش كمتر از يك ماه باشد
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)
End Select
Wend
SubtractDay = (S * 10000) + (M * 100) + (R)
End Function
محتوای مخفی: ماژول تقویم هجری شمسی با توابع جانبی آن