I want to create a calendar converter from Gregorian date to Jalali date and Vice Versa.
Jalali date system uses I Persian country like Iran, Afghanistan, and Tajikistan etc.
The difference between Jalali and Gregorian date see here:
http://en.wikipedia.org/wiki/Iranian_calendar
I have found the free code for this but I don?t know how to use it on the AM..
I s any one can help me?
the code is:
- Code: Select all
Option Compare Database
Option Explicit
Dim mvarGDayTab As Variant
Dim mvarJDayTab As Variant
Dim mvarIsDebug
' Distance in days of origin of Jalali from origin of Gregorian calendar
Const mcGYearOff = 226894
Const mcJYearOff = 621
Const mcSolar = 365.25
Function CurrentFullJalaliDate()
Dim varY
Dim varM
Dim varD
varY = Year(Date)
varM = Month(Date)
varD = Day(Date)
JalaliDate varY, varM, varD, varY, varM, varD
CurrentFullJalaliDate = Right$(varY, 2) & "/" & varM & "/" & varD & " " & DayName(Weekday(Date))
End Function
Function CurrentJalaliDate()
Dim varY
Dim varM
Dim varD
varY = Year(Date)
varM = Month(Date)
varD = Day(Date)
JalaliDate varY, varM, varD, varY, varM, varD
CurrentJalaliDate = varY & FillLeft(varM, "0", 2) & FillLeft(varD, "0", 2)
End Function
Function DayName(pvarADAy)
Select Case pvarADAy
Case 1
DayName = "??????"
Case 2
DayName = "??????"
Case 3
DayName = "?? ????"
Case 4
DayName = "????????"
Case 5
DayName = "??? ????"
Case 6
DayName = "????"
Case 7
DayName = "????"
Case Else
DayName = ""
End Select
End Function
' Compute Gregorian day of year from Year, Month, and Day
Function GDayOfYear(pvarYear, pvarMonth, pvarDay)
Dim varI
Dim varLeap
Dim varD
varD = pvarDay
varLeap = GLeap(pvarYear)
For varI = 1 To pvarMonth - 1
varD = varD + mvarGDayTab(varLeap)(varI)
Next varI
GDayOfYear = varD
End Function
' Decides if Gregorian year a leap one : those years that are
' Divisible by (4 but not 100) & those are divisible by 400
Function GLeap(pvarYear)
If (pvarYear Mod 4 = 0 And pvarYear Mod 100 <> 0) Or (pvarYear Mod 400 = 0) Then
GLeap = 1
Else
GLeap = 0
End If
End Function
' Set Jalali Month & Day from Jalali Year & Day Of Year
Sub GMonthDay(ByVal pvarGYear, ByVal pvarGDayOfYear, pvarMonth, pvarDay)
Dim varI
Dim varLeap
On Error GoTo 1
varLeap = GLeap(pvarGYear)
varI = 1
Do While pvarGDayOfYear > mvarGDayTab(varLeap)(varI)
pvarGDayOfYear = pvarGDayOfYear - mvarGDayTab(varLeap)(varI)
varI = varI + 1
Loop
pvarMonth = varI
pvarDay = pvarGDayOfYear
End Sub
Function GregDays(pvarGYear, pvarGMonth, pvarGDay)
Dim varDiv4
Dim varDiv100
Dim varDiv400
Dim varTotalDays
Dim varTmp
On Error GoTo 1
varDiv4 = (pvarGYear - 1) \ 4
varDiv100 = (pvarGYear - 1) \ 100
varDiv400 = (pvarGYear - 1) \ 400
varTmp = GDayOfYear(pvarGYear, pvarGMonth, pvarGDay)
varTotalDays = (pvarGYear - 1) * 365 + varTmp + varDiv4 - varDiv100 + varDiv400
GregDays = varTotalDays
End Function
' Compute Gregorian date from Jalali Year, Month & Day
Function GregorianDate(pvarJYear, pvarJMonth, pvarJDay, pvarGy, pvarGm, pvarGd)
Dim varTotalDays
Dim varGYear
Dim varGMonth
Dim varGDay
SetConstants
varTotalDays = JalaliDays(pvarJYear, pvarJMonth, pvarJDay)
GregorianYMD varTotalDays, varGYear, varGMonth, varGDay
pvarGy = varGYear
pvarGm = varGMonth
pvarGd = varGDay
End Function
' Compute Gregorian date form Jalali total days
Sub GregorianYMD(ByVal pvarTotalDays, pvarGYear, pvarGMonth, pvarGDay)
Dim varDiv33
Dim varDiv4
Dim varDiv100
Dim varDiv400
Dim varGDays
' Total Gregorian days passed
pvarTotalDays = pvarTotalDays + mcGYearOff
pvarGYear = pvarTotalDays \ (mcSolar - 0.25 / 33)
varDiv4 = pvarGYear \ 4
varDiv100 = pvarGYear \ 100
varDiv400 = pvarGYear \ 400
' Find Gregorian day of year
varGDays = pvarTotalDays - (365 * pvarGYear) - (varDiv4 - varDiv100 + varDiv400)
pvarGYear = pvarGYear + 1
Do While varGDays <= 0
pvarGYear = pvarGYear - 1
If GLeap(pvarGYear) = 1 Then
varGDays = varGDays + 366
Else
varGDays = varGDays + 365
End If
Loop
If (varGDays = 366 And GLeap(pvarGYear) = 0) Then
varGDays = 1
pvarGYear = pvarGYear + 1
End If
GMonthDay pvarGYear, varGDays, pvarGMonth, pvarGDay
End Sub
Function IsGDateValid(pvarY, pvarM, pvarD) As Boolean
If pvarM < 1 Or pvarM > 12 Then
IsGDateValid = False
Exit Function
End If
If pvarY < 1900 Or pvarY > 2100 Then
IsGDateValid = False
Exit Function
End If
SetConstants
If pvarD > mvarGDayTab(GLeap(pvarY))(pvarM) Then
IsGDateValid = False
Exit Function
End If
IsGDateValid = True
End Function
Function IsJDateValid(pvarY, pvarM, pvarD) As Boolean
If pvarM < 1 Or pvarM > 12 Then
IsJDateValid = False
Exit Function
End If
If pvarY < 1300 Or pvarY > 1400 Then
IsJDateValid = False
Exit Function
End If
SetConstants
If pvarD > mvarJDayTab(JLeap(pvarY))(pvarM) Then
IsJDateValid = False
Exit Function
End If
IsJDateValid = True
End Function
' Compute Jalali date from Gregorian Year, Month & Day
Function JalaliDate(ByVal pvarGYear, ByVal pvarGMonth, ByVal pvarGDay, pvarJY, pvarJM, pvarJD)
Dim varTotalDays
Dim varJYear
Dim varJMonth
Dim varJDay
SetConstants
varTotalDays = GregDays(pvarGYear, pvarGMonth, pvarGDay)
JalaliYMD varTotalDays, varJYear, varJMonth, varJDay
pvarJY = varJYear
pvarJM = varJMonth
pvarJD = varJDay
End Function
Function JalaliDays(pvarJYear, pvarJMonth, pvarJDay)
Dim varTotalDays
Dim varLeap
Dim varTmp
On Error GoTo 1
varLeap = JLeapYears(pvarJYear - 1)
varTmp = JDayOfYear(pvarJYear, pvarJMonth, pvarJDay)
varTotalDays = (pvarJYear - 1) * 365 + varLeap + varTmp
JalaliDays = varTotalDays
End Function
Sub JalaliYMD(ByVal pvarTotalDays, pvarJYear, pvarJMonth, pvarJDay)
pvarTotalDays = pvarTotalDays - mcGYearOff
' Estimate full Jalali years passed
pvarJYear = pvarTotalDays \ (mcSolar - 0.25 / 33)
' Find all leap years that have passed
varLeap = JLeapYears(pvarJYear)
varJDays = pvarTotalDays - (365 * pvarJYear + varLeap)
pvarJYear = pvarJYear + 1
Do While varJDays <= 0
pvarJYear = pvarJYear - 1
If JLeap(pvarJYear) = 1 Then
varJDays = varJDays + 366
Else
varJDays = varJDays + 365
End If
Loop
If (varJDays = 366 And JLeap(pvarJYear) = 0) Then
varJDays = 1
pvarJYear = pvarJYear + 1
End If
JMonthDay pvarJYear, varJDays, pvarJMonth, pvarJDay
End Sub
' Compute Jalali day of year from Year, Month, and Day
Function JDayOfYear(pvarYear, pvarMonth, pvarDay)
Dim varI
Dim varLeap
Dim varD
varD = pvarDay
varLeap = JLeap(pvarYear)
For varI = 1 To pvarMonth - 1
varD = varD + mvarJDayTab(varLeap)(varI)
Next varI
JDayOfYear = varD
End Function
'Decides if Jalali year a leap one : those years that have a
' remainder of 1, 5, 9, 13, 17, 22, 26 and 30 when divided by 33
Function JLeap(pvarYear)
Dim varTmp
varTmp = pvarYear Mod 33
If varTmp = 1 Or varTmp = 5 Or varTmp = 9 Or varTmp = 13 Or varTmp = 17 Or varTmp = 22 Or varTmp = 26 Or varTmp = 30 Then
JLeap = 1
Else
JLeap = 0
End If
End Function
' Find all Jalali leap years until JYear
Function JLeapYears(pvarJYear)
Dim varLeap
Dim varCurrentCycle
Dim varDiv33
Dim varI
varDiv33 = pvarJYear \ 33 ' Number of 33-year-periods
varCurrentCycle = pvarJYear - (varDiv33 * 33)
varLeap = varDiv33 * 8
If varCurrentCycle > 0 Then
For varI = 1 To IIf(varCurrentCycle <= 18, varCurrentCycle, 18) Step 4
varLeap = varLeap + 1
Next
End If
If varCurrentCycle > 21 Then
For varI = 22 To IIf(varCurrentCycle <= 30, varCurrentCycle, 30) Step 4
varLeap = varLeap + 1
Next
End If
JLeapYears = varLeap
End Function
' Set Jalali Month & Day from Jalali Year & Day Of Year
Sub JMonthDay(ByVal pvarJYear, ByVal pvarJDayOfYear, pvarMonth, pvarDay)
Dim varI
Dim varLeap
varLeap = JLeap(pvarJYear)
varI = 1
Do While pvarJDayOfYear > mvarJDayTab(varLeap)(varI)
pvarJDayOfYear = pvarJDayOfYear - mvarJDayTab(varLeap)(varI)
varI = varI + 1
Loop
pvarMonth = varI
pvarDay = pvarJDayOfYear
End Sub
Function JTOG(ByVal plngJ As Long) As Date
Dim varGYear
Dim varGMonth
Dim varGDay
Dim varJYear
Dim varJMonth
Dim varJDay
varJYear = Mid(plngJ, 1, 4)
varJMonth = Mid(plngJ, 5, 2)
varJDay = Mid(plngJ, 7, 2)
GregorianDate varJYear, varJMonth, varJDay, varGYear, varGMonth, varGDay
JTOG = DateSerial(varGYear, varGMonth, varGDay)
End Function
Sub SetConstants()
mvarGDayTab = Array(Array(0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31), Array(0, 31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31))
mvarJDayTab = Array(Array(0, 31, 31, 31, 31, 31, 31, 30, 30, 30, 30, 30, 29), Array(0, 31, 31, 31, 31, 31, 31, 30, 30, 30, 30, 30, 30))
mvarIsDebug = 0
End Sub
Function DateValid()
DateValid = IsDateValid(Screen.ActiveControl)
End Function
Function JDateAdd(JDate, D)
If Nz(JDate, 0) = 0 Then JDateAdd = Null: Exit Function
Dim GY, GM, GD, JY, JM, JD
JY = Left(JDate, 4)
JM = Mid(JDate, 5, 2)
JD = Right(JDate, 2)
GregorianDate JY, JM, JD, GY, GM, GD
Dim GDate As Date
GDate = DateSerial(GY, GM, GD)
GDate = DateAdd("d", D, GDate)
GY = Year(GDate)
GM = Month(GDate)
GD = Day(GDate)
JalaliDate GY, GM, GD, JY, JM, JD
JDateAdd = JY & FillLeft(JM, "0", 2) & FillLeft(JD, "0", 2)
End Function
