اين اولي كه نوشتة يكي از دوستامه جمع و جوره ولي بازة زماني داره، تا جايي كه يادمه تا 1387 كار ميكنه. ضمناً يادت باشه كه همة اينها نياز به اين دارند كه بري توي Regional Setting قالب رو عوض كني به اوني كه توش نوشته.[code:1]
Attribute VB_Name = "modFDate"
Type PersianDate
pDay As Integer
pMonth As Integer
pYear As Integer
End Type
Function Chr2Per(ChrDate As Date) As String ', Optional FDate As PersianDate)
'********************************************
'********************************************
'Routins to convert Christian calendar date to
'Persian Shamsi calendar date.
'WARNING: this routin works correctly only in
'years 62 through 87
'Last revision: Thu-4 FEB, 1999 Vahid Bohlul
'Last revision: Wed-31 MAR, 1999 Vahid Bohlul
'********************************************
'********************************************
Dim Year(25) As Integer
Dim RefDate As Date
Dim DateDiff As Integer
Dim Count As Integer
Dim month_count As Integer
Dim Year_Date As Integer
Dim FDate As PersianDate
Year(0) = 366 '62
Year(1) = 365 '63
Year(2) = 365 '64
Year(3) = 365 '65
Year(4) = 366 '66
Year(5) = 365 '67
Year(6) = 365 '68
Year(7) = 365 '69
Year(8) = 366 '70
Year(9) = 365 '71
Year(10) = 365 '72
Year(11) = 365 '73
Year(12) = 365 '74
Year(13) = 366 '75
Year(14) = 365 '76
Year(15) = 365 '77
Year(16) = 365 '78
Year(17) = 366 '79
Year(18) = 365 '80
Year(19) = 365 '81
Year(20) = 365 '82
Year(21) = 366 '83
Year(22) = 365 '84
Year(23) = 365 '85
Year(24) = 365 '86
Year(25) = 366 '87
RefDate = "21/3/1983"
Count = 0
month_count = 0
DateDiff = ChrDate - RefDate + 1
Year_Date = DateDiff
For Count = 0 To 25
If Year_Date > Year(Count) Then
Year_Date = Year_Date - Year(Count)
Else
Exit For
End If
Next Count
FDate.pYear = 1362 + Count
month_date = Year_Date
Do While month_date > 31 And month_count <= 5
month_date = month_date - 31
month_count = month_count + 1
Loop
Do While month_date > 30 And month_count > 5
month_date = month_date - 30
month_count = month_count + 1
Loop
month_count = month_count + 1
FDate.pMonth = month_count
FDate.pDay = month_date
Chr2Per = FDate.pYear & "/" & FDate.pMonth & "/" & FDate.pDay
End Function
Sub Per2Chr(FDate As PersianDate, ByRef ChrDate As Date)
Dim Year(25) As Integer
Dim Month(12) As Integer
Dim Days As Integer
Dim Years As Integer
Dim Counter As Integer
Year(0) = 366 '62
Year(1) = 365 '63
Year(2) = 365 '64
Year(3) = 365 '65
Year(4) = 366 '66
Year(5) = 365 '67
Year(6) = 365 '68
Year(7) = 365 '69
Year(8) = 366 '70
Year(9) = 365 '71
Year(10) = 365 '72
Year(11) = 365 '73
Year(12) = 365 '74
Year(13) = 366 '75
Year(14) = 365 '76
Year(15) = 365 '77
Year(16) = 365 '78
Year(17) = 366 '79
Year(18) = 365 '80
Year(19) = 365 '81
Year(20) = 365 '82
Year(21) = 366 '83
Year(22) = 365 '84
Year(23) = 365 '85
Year(24) = 365 '86
Year(25) = 366 '87
Month(0) = 31
Month(1) = 31
Month(2) = 31
Month(3) = 31
Month(4) = 31
Month(5) = 31
Month(6) = 30
Month(7) = 30
Month(8) = 30
Month(9) = 30
Month(10) = 30
Month(11) = 29
ChrDate = "21/3/1983"
Days = 0
Years = FDate.pYear - 1362
For Counter = 0 To Years - 1
Days = Days + Year(Counter)
Next Counter
For Counter = 0 To FDate.pMonth - 2
Days = Days + Month(Counter)
Next Counter
Days = Days + FDate.pDay
ChrDate = ChrDate + Days - 1
End Sub[/code:1]