Excel_Function/DiffTarikh.bas at master · kharazian/Excel_Function · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
Attribute VB_Name = "Module1"
' ************************************************** ***********
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 Variant) As Byte
'æÑæÏí ÊÇÈÚ ÚÏÏ ÏæÑÞãí ÇÓÊ
'Çíä ÊÇÈÚ ßÈíÓå ÈæÏä ÓÇá ÑÇ ÈÑãíÑÏÇäÏ
'ÇÑ ÓÇá ßÈíÓå ÈÇÔÏ ÚÏÏ íß æ ÏÑÛíÑ ÇíäÕæÑÊ ÕÝÑ ÑÇ ÈÑ ãíÑÏÇäÏ
Kabiseh = 0
If OnlySal >= 1375 Then
If (OnlySal - 1375) Mod 4 = 0 Then
Kabiseh = 1
Exit Function
End If
ElseIf OnlySal <= 1370 Then
If (1370 - OnlySal) Mod 4 = 0 Then
Kabiseh = 1
Exit Function
End If
End If

End Function
'*******************************************
Public Function AddDay(ByVal F_Date As Long, ByVal Add As Integer) As Long
Dim K, M, R, Days As Byte
Dim s As Integer
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)
AddDay = CLng(s & Format(M, "00") & Format(R, "00"))
End Function

'***********************************************
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
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

'***********************************************
Public Function Diff2(ByVal FromDate As Long, ByVal To_Date As Long) As Long
Dim S1, M1, r1, S2, M2, r2, rs, rm, rr As Integer

If FromDate = 0 Or IsNull(FromDate) = True Or To_Date = 0 Or IsNull(To_Date) = True Or FromDate > To_Date Then
Diff2 = 0
Exit Function
End If

r1 = Rooz(FromDate)
M1 = Mah(FromDate)
S1 = Sal(FromDate)
r2 = Rooz(To_Date)
M2 = Mah(To_Date)
S2 = Sal(To_Date)
'--------------------------------------------------------------------------------------
rr = r2 - r1
rm = M2 - M1
rs = S2 - S1
'--------------------------------------------------------------------------------------
If rr < 0 Then
    If M2 > 1 Then
        rm = rm - 1
        rr = MahDays(S2, M2 - 1) + rr
    Else
        rm = 12
        rs = rs - 1
        rr = MahDays(S2 - 1, 12) + rr
    End If
End If

If rm < 0 Then
    rs = rs - 1
    rm = 12 + rm
End If

Diff2 = (rs * 100 + rm) * 100 + rr
End Function

'***********************************************
Public Function muldate(ByVal F_Date As Long) As Long
Dim S1, M1, r1, rs, rm, rr As Integer

r1 = Rooz(F_Date)
M1 = Mah(F_Date)
S1 = Sal(F_Date)

'--------------------------------------------------------------------------------------
rr = 2 * r1
rm = 2 * M1
rs = 2 * S1
'--------------------------------------------------------------------------------------
If rr > 30 Then
    rr = rr - 30
    rm = rm + 1
End If

If rm > 12 Then
    rs = rs + 1
    rm = rm - 12
End If

muldate = (rs * 100 + rm) * 100 + rr
End Function