'این متغیر مقدار کلیک شده در فرم تقویم را به‌صورت سراسری در خودش ذخیره می‌کند
Public strDate As String

'////////////////////////////////////////////////////
' ماژول اصلاح‌شدهٔ جناب آزادی توسط احمد میرزازاده به تاریخ 1388/7/22
' ...

'*******************************************
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 Integer
    'این تابع عدد مربوط به سال یک تاریخ را برمی‌گرداند
    Sal = Int(F_Date / 10000)
End Function

'*******************************************
Public Function Kabiseh(ByVal OnlySal As Integer) As Byte
    'ورودی تابع عدد دورقمی است
    'این تابع کبیسه بودن سال را برمی‌گرداند
    'اگر سال کبیسه باشد، عدد یک و درغیر اینصورت صفر را برمی‌گرداند
    Kabiseh = 0
    If OnlySal >= 1375 Then
        If (OnlySal - 1375) Mod 4 = 0 Then
            Kabiseh = 1
        End If
    ElseIf OnlySal <= 1370 Then
        If (1370 - OnlySal) Mod 4 = 0 Then
            Kabiseh = 1
        End If
    End If
End Function

'*******************************************
Function ValidDate(F_Date As Long) As Boolean
    Dim M As Byte, s As Integer, R As Byte
    ' این تابع اعتبار یک عدد ورودی را از نظر تاریخ هجری شمسی بررسی می‌کند
    ' را برمی‌گرداند False واگر نامعتبر باشد True اگر تاریخ معتبر باشد
    ValidDate = True
    s = Sal(F_Date)
    M = Mah(F_Date)
    R = Rooz(F_Date)
    
    If F_Date < 10000101 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 As Byte, M As Byte, R As Byte, Days As Byte
    Dim s As Integer
    
    If Not ValidDate(F_Date) Then
        MsgBox "تاریخ ورودی نامعتبر است."
        Exit Function
    End If
    
    R = Rooz(F_Date)
    M = Mah(F_Date)
    s = Sal(F_Date)
    K = Kabiseh(s)
    
    While Add > 0
        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
    Wend
    
    AddDay = CLng(s & Format(M, "00") & Format(R, "00"))
End Function

'***********************************************
Public Function Shamsi() As Long
    'تاریخ جاری سیستم را به تاریخ هجری شمسی تبدیل می‌کند
    Dim Shamsi_Mabna As Long
    Dim Miladi_mabna As Date
    Dim Dif As Long
    
    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 miladibeshamsi(M_Date As Date) As Long
    'تاریخ شمسی ورودی را به تاریخ میلادی تبدیل می‌کند
    Dim Shamsi_Mabna As Long
    Dim Miladi_mabna As Date
    Dim Dif As Long
    
    Shamsi_Mabna = 13781011
    Miladi_mabna = #1/1/2000#
    Dif = DateDiff("d", Miladi_mabna, M_Date)
    
    If Dif < 0 Then
        MsgBox "تاریخ جاری سیستم شما نادرست است , آنرا اصلاح کنید."
    Else
        miladibeshamsi = AddDay(Shamsi_Mabna, Dif)
    End If
End Function

'***********************************************
Public Function shamsibemiladi(F_Date As Long) As Date
    'تاریخ شمسی ورودی را به تاریخ میلادی تبدیل می‌کند
    Dim Shamsi_Mabna As Long
    Dim Miladi_mabna As Date
    Dim Dif As Long
    
    Shamsi_Mabna = 13781011
    Miladi_mabna = #1/1/2000#
    
    If ValidDate(F_Date) Then
        Dif = Diff(Shamsi_Mabna, F_Date)
        shamsibemiladi = Miladi_mabna + Dif
    Else
        shamsibemiladi = 0
    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) & " " & 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 As Integer, M1 As Byte, r1 As Byte
    Dim S2 As Integer, M2 As Byte, r2 As Byte
    Dim Sumation As Single
    Dim Flag As Boolean
    
    Flag = False
    If FromDate = 0 Or IsNull(FromDate) Or To_Date = 0 Or IsNull(To_Date) 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
            Sumation = Sumation + 366
        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
                Sumation = Sumation + 31
                M1 = M1 + 1
            Case 7 To 11
                Sumation = Sumation + 30
                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 Then
        Sumation = -Sumation
    End If
    
    Diff = Sumation
End Function

'***********************************************
Public Function DayWeekNo(F_Date As Long) As Byte
    'این تابع یک تاریخ را دریافت کرده و مشخص می‌کند چه روزی از هفته است
    Dim Shmsi_Mabna As Long
    Dim Dif As Long
    
    Shmsi_Mabna = 13801011
    Dif = Diff(Shmsi_Mabna, F_Date)
    
    If Shmsi_Mabna > F_Date Then
        Dif = -Dif
    End If
    
    DayWeekNo = (Dif + 3) Mod 7
    If DayWeekNo < 0 Then
        DayWeekNo = DayWeekNo + 7
    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 MahDays(ByVal Sal As Integer, 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) 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 SubtractDay(ByVal F_Date As Long, ByVal Subtract As Long) As Long
    Dim K As Byte, M As Byte, s As Integer, R As Byte, Days As Byte
    
    If Not ValidDate(F_Date) Then
        MsgBox "تاریخ ورودی نامعتبر است."
        Exit Function
    End If
    
    R = Rooz(F_Date)
    M = Mah(F_Date)
    s = Sal(F_Date)
    K = Kabiseh(s)
    
    While Subtract > 0
        If Subtract >= R - 1 Then
            Subtract = Subtract - (R - 1)
            R = 1
            If M >= 2 Then
                M = M - 1
            Else
                s = s - 1
                M = 12
            End If
        Else
            R = R - Subtract
            Subtract = 0
        End If
        
        If Subtract > 0 Then
            Days = MahDays(IIf(M >= 2, s, s - 1), IIf(M >= 2, M - 1, 12))
            If Subtract >= Days Then
                Subtract = Subtract - Days
                If M >= 2 Then
                    M = M - 1
                Else
                    s = s - 1
                    M = 12
                End If
            Else
                R = Days - Subtract + 1
                Subtract = 0
            End If
        End If
    Wend
    
    SubtractDay = CLng(s & Format(M, "00") & Format(R, "00"))
End Function