Option Compare Database '\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ' ا' ماژول تکميل شده جناب آزادي توسط رسول غلامي در تاريخ 1394/09/10 ' 'ا ' .تعريف كنيد Number(Long) است را بصورت Date ا' 1 - فيلدهايي كه نوع آنها ' .اين فيلدها را بصورت -,0000/00/0,0 تنظيم كنيد InputMask ا' 2- خاصيت ' .ا' 3- بدليل 8 رقمي در نظر گرفتن فيلد تاريخ ، اين ماژول تا سال 9999 كارايي دارد ' .تاريخ جاري سيستم را به هجري شمسي تبديل مي كند Shamsi() ا' 5- تابع ' .بكار ببريد Now() را مي توانيد در گزارشات بجاي تابع Dat() ا' 6- تابع ' .را ميتوانيد جهت درج / در بين اعداد تاريخ استفاده كنيد Slash() ا' 7- تابع ' " استفاده كنيد Slash(Shamsi()) ا' "جهت ايجاد / در بين اعداد تاريخ تابع را بشكل ' : ا' 8- براي جلوگيري از ورود تاريخ غلط درون يك فيلد بترتيب زير عمل كنيد ' "فيلد مورد نظر قرار دهيد ValidationRule را در خاصيت ValidDate([Field Name])=True ا' "تابع '///////////////////////////////////////////////////////////////////////////////////////////// Public Static Function Shamsi() As Long 'اين تابع تاريخ جاري سيستم را به تاريخ هجري شمسي تبديل مي كند '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Dim Shamsi_Mabna As Long Dim Miladi_mabna As Date Dim Dif As Long 'در اينجا 78/10/11 با 2000/01/01 معادل قرارداده شده Shamsi_Mabna = 13781011 Miladi_mabna = #1/1/2000# Dif = DateDiff("d", Miladi_mabna, Date) If Dif < 0 Then MsgBox "تاريخ جاري سيستم شما نادرست است , آنرا اصلاح كنيد." Else Shamsi = AddDay(Shamsi_Mabna, Dif) End If End Function Public Function Dat() As String ' بكار ببريد Now() را مي توانيد در گزارشات بجاي تابع Dat() تابع '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Dat = DayWeek(Shamsi) & " - " & Slash(Shamsi) End Function Public Function Slash(F_Date As Variant) As String ' اين تابع يك تاريخ را دريافت و بصورت يك رشته 10 رقمي شامل / و چهار رقم براي سال بازميگرداند '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> F_Date = Replace(F_Date, "/", "") Dim A As Long A = CLng(F_Date) Slash = Format(IL(A), "0000") & "/" & Format(Ay(A), "00") & "/" & Format(Guon(A), "00") 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 = Mid(D, 1, 4) & "/" & Mid(D, 5, 2) & "/" & Mid(D, 7, 2) End If End Function Function ValidDate(F_Date As Variant) As Boolean ' اين تابع اعتبار يك عدد ورودي را از نظر تاريخ هجري شمسي بررسي مي كند ' را برمي گرداند False واگر نامعتبر باشد True اگر تاريخ معتبر باشد '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> On Error GoTo Err_ValidDate Dim M, S, R As Byte F_Date = Replace(F_Date, "/", "") R = Guon(CLng(F_Date)) M = Ay(CLng(F_Date)) S = IL(CLng(F_Date)) If F_Date < 10000101 Then Exit Function If M > 12 Or M = 0 Or R = 0 Then Exit Function If R > ayDays(S, M) Then Exit Function ValidDate = True Exit_ValidDate: On Error Resume Next Exit Function Err_ValidDate: Select Case err.Number Case 0 Resume Exit_ValidDate: Case 94 ValidDate = True Case Else MsgBox err.Number & " " & err.Description, vbExclamation, "Error in module Module2 - function ValidDate" Resume Exit_ValidDate: End Select End Function Public Function AddDay(ByVal F_Date As Variant, ByVal Add As Long) As Long 'اين تابع تعداد روز دلخواه را به تاريخ روز اضافه ميكند '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> On Error GoTo Err_AddDay F_Date = Replace(F_Date, "/", "") Dim k, M, R, Days As Byte Dim S As Integer R = Guon(CLng(F_Date)) M = Ay(CLng(F_Date)) S = IL(CLng(F_Date)) k = Kabiseh(S) 'تبديل روز به عدد 1 جهت ادامه محاسبات و يا اتمام محاسبه Days = ayDays(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 = ayDays(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 = CLng(S & Format(M, "00") & Format(R, "00")) Exit_AddDay: On Error Resume Next Exit Function Err_AddDay: Select Case err.Number Case 0 Resume Exit_AddDay: Case 94 AddDay = 0 Case Else MsgBox err.Number & " " & err.Description, vbExclamation, "Error in module Module2 - function AddDay" Resume Exit_AddDay: End Select End Function Function SubDay(ByVal F_Date As Variant, ByVal Subtract As Long) As Long 'به تعداد روز معيني از يك تاريخ كم كرده و تاريخ حاصله را ارائه ميكند '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> On Error GoTo Err_SubDay F_Date = Replace(F_Date, "/", "") Dim k, M, S, R, Days As Byte R = Guon(CLng(F_Date)) M = Ay((CLng(F_Date))) S = IL((CLng(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 = ayDays(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 SubDay = (S * 10000) + (M * 100) + (R) Exit_SubDay: On Error Resume Next Exit Function Err_SubDay: Select Case err.Number Case 0 Resume Exit_SubDay: Case 94 SubDay = 0 Case Else MsgBox err.Number & " " & err.Description, vbExclamation, "Error in module Module2 - function SubDay" Resume Exit_SubDay: End Select End Function Public Function DayWeekNo(F_Date As Variant) As Byte 'اين تابع يك تاريخ را دريافت كرده و شماره روز هفته را مشخص مي كند 'اگر شنبه باشد عدد 0 'اگر 1شنبه باشد عدد 1 '...... 'اگر جمعه باشد عدد 6 '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> F_Date = Replace(F_Date, "/", "") Dim day As String Dim Shmsi_Mabna As Long Dim Dif As Long 'مبنا 80/10/11 Shmsi_Mabna = 13801011 Dif = Diff(Shmsi_Mabna, CLng(F_Date)) If Shmsi_Mabna > CLng(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 Public Function DayWeek(F_Date As Variant) 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 Function MahName(F_Date As Variant) As String 'اين تابع يك تاريخ را دريافت كرده و مشخص مي كند چه ماهي از سال است '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> F_Date = Replace(F_Date, "/", "") ay_no = Ay(CLng(F_Date)) Select Case ay_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 Public Function FirstDate(F_Date As Variant) As String 'اين تابع تاريخ اول سال را برمي گرداند '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> F_Date = Replace(F_Date, "/", "") Dim S As Integer S = IL(CLng(F_Date)) FirstDate = SubDay(S & "/01/01", 1) End Function Public Function RozeSal(F_Date As Variant) As String 'اين تابع تاريخ اول سال را برمي گرداند '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> RozeSal = Diff(FirstDate(F_Date), F_Date) End Function Public Function HafteSal(F_Date As Variant) As String 'اين تابع تاريخ اول سال را برمي گرداند '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Dim Tmp As Integer Tmp = RozeSal(F_Date) HafteSal = Int(Tmp / 7) + 1 End Function Public Function Diff(ByVal Date1 As Variant, ByVal Date2 As Variant) As Long 'اين تابع تعداد روزهاي بين دو تاريخ را ارائه مي كند On Error GoTo Err_Diff '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Date1 = Replace(Date1, "/", "") Date2 = Replace(Date2, "/", "") Dim Tmp As Long Dim S1, M1, R1, S2, M2, R2 As Integer Dim Sumation As Single Dim Flag As Boolean Flag = False If CLng(Date1) = 0 Or IsNull(CLng(Date1)) = True Or CLng(Date2) = 0 Or IsNull(CLng(Date2)) = True Then Diff = 0 Exit Function End If 'اگر تاريخ شروع از تاريخ پايان بزرگتر باشد آنها موقتا جابجا مي شوند If CLng(Date1) > CLng(Date2) Then Flag = True Tmp = CLng(Date1) Date1 = CLng(Date2) Date2 = Tmp End If R1 = Guon(CLng(Date1)) M1 = Ay(CLng(Date1)) S1 = IL(CLng(Date1)) R2 = Guon(CLng(Date2)) M2 = Ay(CLng(Date2)) S2 = IL(CLng(Date2)) 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 Exit_Diff: On Error Resume Next Exit Function Err_Diff: Select Case err.Number Case 0 Resume Exit_Diff: Case 94 Diff = 0 Case Else MsgBox err.Number & " " & err.Description, vbExclamation, "Error in module Module2 - function Diff" Resume Exit_Diff: End Select End Function Public Function TotalDiff(ByVal Date1 As Variant, ByVal Date2 As Variant) As String 'اين تابع تعداد روزهاي بين دو تاريخ را ارائه مي كند On Error GoTo Err_TotalDiff '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Date1 = Replace(Date1, "/", "") Date2 = Replace(Date2, "/", "") Dim Tmp As Long Dim S1, M1, R1, S2, M2, R2, RozeSal, RozeMah, roz, SalNo, MahNo, RozNo As Integer Dim Sumation As Single Dim Flag As Boolean Flag = False If CLng(Date1) = 0 Or IsNull(CLng(Date1)) = True Or CLng(Date2) = 0 Or IsNull(CLng(Date2)) = True Then TotalDiff = 0 Exit Function End If 'اگر تاريخ شروع از تاريخ پايان بزرگتر باشد آنها موقتا جابجا مي شوند If CLng(Date1) > CLng(Date2) Then Flag = True Tmp = CLng(Date1) Date1 = CLng(Date2) Date2 = Tmp End If R1 = Guon(CLng(Date1)) M1 = Ay(CLng(Date1)) S1 = IL(CLng(Date1)) R2 = Guon(CLng(Date2)) M2 = Ay(CLng(Date2)) S2 = IL(CLng(Date2)) RozeSal = 0 RozeMah = 0 roz = 0 SalNo = 0 MahNo = 0 RozNo = 0 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 '################# SalNo = SalNo + 1 '################# Else Sumation = Sumation + 366 '################# SalNo = SalNo + 1 '################# End If Else Sumation = Sumation + 365 '################# SalNo = SalNo + 1 '################# End If S1 = S1 + 1 Loop '################## RozeSal = Sumation '################## 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 '################# MahNo = MahNo + 1 '################# Else Sumation = Sumation + 31 '################# MahNo = MahNo + 1 '################# End If M1 = M1 + 1 Case 7 To 11 If M1 = 11 And R1 = 30 And Kabiseh(S1) = 0 Then Sumation = Sumation + 29 '################# MahNo = MahNo + 1 '################# R1 = 29 Else Sumation = Sumation + 30 '################# MahNo = MahNo + 1 '################# End If M1 = M1 + 1 Case 12 If Kabiseh(S1) = 1 Then Sumation = Sumation + 30 '################# MahNo = MahNo + 1 '################# Else Sumation = Sumation + 29 '################# MahNo = MahNo + 1 '################# End If S1 = S1 + 1 M1 = 1 End Select Loop '################## RozeMah = Sumation - RozeSal '################## If M1 = M2 Then Sumation = Sumation + (R2 - R1) '##################### RozNo = RozNo + (R2 - R1) If RozNo < 0 Then If Kabiseh(S1 - 1) = 1 Then RozNo = 30 + RozNo Else RozNo = 29 + RozNo End If MahNo = MahNo - 1 End If '##################### Else Select Case M1 Case 1 To 6 Sumation = Sumation + (31 - R1) + R2 '##################### RozNo = RozNo + (31 - R1) + R2 '##################### Case 7 To 11 Sumation = Sumation + (30 - R1) + R2 '##################### RozNo = RozNo + (30 - R1) + R2 '##################### Case 12 If Kabiseh(S1) = 1 Then Sumation = Sumation + (30 - R1) + R2 '##################### RozNo = RozNo + (30 - R1) + R2 '##################### Else Sumation = Sumation + (29 - R1) + R2 '##################### RozNo = RozNo + (29 - R1) + R2 '##################### End If End Select End If '################## roz = Sumation - (RozeSal + RozeMah) '################## If Flag = True Then RozeSal = -RozeSal End If TotalDiff = SalNo & "/" & MahNo & "/" & RozNo Exit_TotalDiff: On Error Resume Next Exit Function Err_TotalDiff: Select Case err.Number Case 0 Resume Exit_TotalDiff: Case 94 TotalDiff = 0 Case Else MsgBox err.Number & " " & err.Description, vbExclamation, "Error in module Date Shamsi - function TotalDiff" Resume Exit_TotalDiff: End Select End Function Function ayDays(ByVal IL As Integer, ByVal Ay As Byte) As Byte 'اين تابع تعداد روزهاي يك ماه را برمي گرداند '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Select Case Ay Case 1 To 6 ayDays = 31 Case 7 To 11 ayDays = 30 Case 12 If Kabiseh(IL) = 1 Then ayDays = 30 Else ayDays = 29 End If End Select End Function '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 'اين توابع داخلي هستند و براي استفاده کاربر طراحي نشده اند تغيير در اين توابع مجاز نميباشد '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Function ILay(ByVal F_Date As Long) As Long 'اين تابع داخلي است 'شش رقم اول تاريخ كه معرف سال و ماه است را برمي گرداند '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> ILay = val(Left$(F_Date, 6)) End Function Public Function Guon(F_Date As Long) As Byte 'اين تابع داخلي است 'اين تابع عدد مربوط به روز يك تاريخ را برمگرداند '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Guon = F_Date Mod 100 End Function Function Ay(F_Date As Long) As Byte 'اين تابع داخلي است 'اين تابع عدد مربوط به ماه يك تاريخ را برمگرداند '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Ay = Int((F_Date Mod 10000) / 100) End Function Public Function IL(F_Date As Long) As Integer 'اين تابع داخلي است 'اين تابع عدد مربوط به سال يك تاريخ را برمگرداند '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> IL = Int(F_Date / 10000) End Function Public Function Kabiseh(ByVal OnlyIL As Variant) As Byte 'اين تابع داخلي است 'ورودي تابع عدد دورقمي است 'اين تابع كبيسه بودن سال را برميگرداند 'اگر سال كبيسه باشد عدد يك و درغير اينصورت صفر را بر ميگرداند '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Kabiseh = 0 If OnlyIL >= 1375 Then If (OnlyIL - 1375) Mod 4 = 0 Then Kabiseh = 1 Exit Function End If ElseIf OnlyIL <= 1370 Then If (1370 - OnlyIL) Mod 4 = 0 Then Kabiseh = 1 Exit Function End If End If End Function Function Nextay(ByVal IL_ay As Long) As Long 'اين تابع داخلي است 'اين تابع عدد ماه بعدي تاريخ را برمي گرداند '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> If (IL_ay Mod 100) = 12 Then Nextay = (Int(IL_ay / 100) + 1) * 100 + 1 Else Nextay = IL_ay + 1 End If End Function Function Previousay(ByVal IL_ay As Long) As Long 'اين تابع داخلي است 'اين تابع عدد ماه قبلي تاريخ را برمي گرداند '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> If (IL_ay Mod 100) = 1 Then Previousay = (Int(IL_ay / 100) - 1) * 100 + 12 Else Previousay = IL_ay - 1 End If End Function Public Function Firstday(IL As Integer, Ay As Integer) As Long 'اين تابع داخلي است 'اين تابع شماره اولين روز ماه را برمي گرداند '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Dim strfd As Long strfd = IL & Format(Ay, "00") & Format(1, "00") Firstday = DayWeekNo(strfd) End Function