mahdif123
چهارشنبه 19 تیر 1387, 07:47 صبح
با سلام
دوستان عزيز مرا در اين مورد راهنمايي كنيد .
سورس كدي دارم كه تاريخ هجري شمسي آقاي حميد آزاد مي باشد اما فكر ميكنم براي ورود تاريخ از سال 1300 تا سال 1900 مي باشد آيا مي شود كاري كرد مقدار آن بيشتر شود يعني قبل از 1300 و بعد از 1900 .
----------نمونه سورس--------------------------
Option Compare Database
'Use openSource program.
' ************************************************** ***********
' برنامه نويس حميد آزاد
' Email: azadi1355@yahoo.com
' Web Address: http://try.persianblog.com
' ويرايش سوم : زمستان 1381
' ************************************************** ***********
' 1- ÊÚÑíÝ ˜äíÏ Number(Long) ÇÓÊ ÑÇ ÈÕæÑÊ Date ÝíáÏåÇíí ˜å äæÚ ÂäåÇ
' 2- Çíä ÝíáÏåÇ ÑÇ ÈÕæÑÊ 00/00/00 ÊäÙíã ˜äíÏ InputMask ÎÇÕíÊ
' ÈÏáíá 6 ÑÞãí ÏÑ äÙÑ ÑÝÊä ÝíáÏ ÊÇÑíÎ ¡ Çíä ÊæÇÈÚ ÊÇ ÓÇá 1399 ˜ÇÑÇíí ÏÇÑÏ
' ...
' ÊÇÑíÎ ÌÇÑí ÓíÓÊã ÑÇ Èå åÌÑí ÔãÓí ÊÈÏíá ãí ˜äÏ Shamsi() ÊÇÈÚ
' ȘÇÑ ÈÈÑíÏ Now() ÑÇ ãí ÊæÇäíÏ ÏÑ ÒÇÑÔÇÊ ÈÌÇí ÊÇÈÚ Dat() ÊÇÈÚ
' :ÈÑÇí ÌáæíÑí ÇÒ æÑæÏ ÊÇÑíÎ ÛáØ Èå ÏÑæä í˜ ÝíáÏ ÈÊÑÊíÈ ÒíÑ Úãá ãí˜äíÏ
' :ÈÔ˜á ÒíÑ È˜ÇÑ ÈÈÑíÏ ValidationRule ÑÇ ÏÑ ÎÇÕíÊ ValidDate() ÊÇÈÚ
' ValidDate([äÇã ÝíáÏ])=True
' ...
' ************************************************** ***********
'*******************************************
' ÈÑäÇãå äæ?Ó : Íã?Ï ÂÒÇÏ?
' Email: azadi1355@yahoo.com
' Web Address: http://try.persianblog.com
' æ?ÑÇ?Ô Óæã : ÒãÓÊÇä 1381
'*******************************************
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/2001#
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
دوستان عزيز مرا در اين مورد راهنمايي كنيد .
سورس كدي دارم كه تاريخ هجري شمسي آقاي حميد آزاد مي باشد اما فكر ميكنم براي ورود تاريخ از سال 1300 تا سال 1900 مي باشد آيا مي شود كاري كرد مقدار آن بيشتر شود يعني قبل از 1300 و بعد از 1900 .
----------نمونه سورس--------------------------
Option Compare Database
'Use openSource program.
' ************************************************** ***********
' برنامه نويس حميد آزاد
' Email: azadi1355@yahoo.com
' Web Address: http://try.persianblog.com
' ويرايش سوم : زمستان 1381
' ************************************************** ***********
' 1- ÊÚÑíÝ ˜äíÏ Number(Long) ÇÓÊ ÑÇ ÈÕæÑÊ Date ÝíáÏåÇíí ˜å äæÚ ÂäåÇ
' 2- Çíä ÝíáÏåÇ ÑÇ ÈÕæÑÊ 00/00/00 ÊäÙíã ˜äíÏ InputMask ÎÇÕíÊ
' ÈÏáíá 6 ÑÞãí ÏÑ äÙÑ ÑÝÊä ÝíáÏ ÊÇÑíÎ ¡ Çíä ÊæÇÈÚ ÊÇ ÓÇá 1399 ˜ÇÑÇíí ÏÇÑÏ
' ...
' ÊÇÑíÎ ÌÇÑí ÓíÓÊã ÑÇ Èå åÌÑí ÔãÓí ÊÈÏíá ãí ˜äÏ Shamsi() ÊÇÈÚ
' ȘÇÑ ÈÈÑíÏ Now() ÑÇ ãí ÊæÇäíÏ ÏÑ ÒÇÑÔÇÊ ÈÌÇí ÊÇÈÚ Dat() ÊÇÈÚ
' :ÈÑÇí ÌáæíÑí ÇÒ æÑæÏ ÊÇÑíÎ ÛáØ Èå ÏÑæä í˜ ÝíáÏ ÈÊÑÊíÈ ÒíÑ Úãá ãí˜äíÏ
' :ÈÔ˜á ÒíÑ È˜ÇÑ ÈÈÑíÏ ValidationRule ÑÇ ÏÑ ÎÇÕíÊ ValidDate() ÊÇÈÚ
' ValidDate([äÇã ÝíáÏ])=True
' ...
' ************************************************** ***********
'*******************************************
' ÈÑäÇãå äæ?Ó : Íã?Ï ÂÒÇÏ?
' Email: azadi1355@yahoo.com
' Web Address: http://try.persianblog.com
' æ?ÑÇ?Ô Óæã : ÒãÓÊÇä 1381
'*******************************************
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/2001#
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