Code:
Const IslamicEpoch = 227014 Public Sub Gregorian2GhamariHijri(ByVal GDay As Integer, ByVal GMonth As Integer, ByVal GYear As Integer, ByRef GHDay As Integer, ByRef GHMonth As Integer, ByRef GHYear As Integer) Call Absolute2Islamic(Gregorian2Absolute(GDay, GMonth, GYear), GHDay, GHMonth, GHYear) End Sub Private Function lastDayOfGregorianMonth(GMonth As Integer, GYear As Integer) As Integer ' Compute the last date of the month for the Gregorian calendar. If (GMonth = 2) Then If (GYear Mod 4 = 0 And GYear Mod 100 <> 0) Or (GYear Mod 400 = 0) Then lastDayOfGregorianMonth = 29 Exit Function End If End If Select Case GMonth Case 1 lastDayOfGregorianMonth = 31 Case 2 lastDayOfGregorianMonth = 28 Case 3 lastDayOfGregorianMonth = 31 Case 4 lastDayOfGregorianMonth = 30 Case 5 lastDayOfGregorianMonth = 31 Case 6 lastDayOfGregorianMonth = 30 Case 7 lastDayOfGregorianMonth = 31 Case 8 lastDayOfGregorianMonth = 31 Case 9 lastDayOfGregorianMonth = 30 Case 10 lastDayOfGregorianMonth = 31 Case 11 lastDayOfGregorianMonth = 30 Case 12 lastDayOfGregorianMonth = 31 End Select End Function Private Function Gregorian2Absolute(GDay As Integer, GMonth As Integer, GYear As Integer) As Currency ' Computes the absolute date from the Gregorian date. Dim N As Integer Dim m As Integer N = GDay ' days this month For m = GMonth - 1 To 1 Step -1 ' days in prior months this year N = N + lastDayOfGregorianMonth(m, GYear) Next Gregorian2Absolute = Int(N + 365 * (CCur(GYear) - 1) + (CCur(GYear) - 1) / 4 - (CCur(GYear) - 1) / 100 + (CCur(GYear) - 1) / 400) End Function Private Sub Absolute2Islamic(Absolute As Currency, GHDay As Integer, GHMonth As Integer, GHYear As Integer) ' Computes the Islamic date from the absolute date. If (Absolute <= IslamicEpoch) Then ' Date is pre-Islamic GHMonth = 0 GHDay = 0 GHYear = 0 Else ' Search forward year by year from approximate year GHYear = Int((Absolute - IslamicEpoch) / 355) While (Absolute >= Islamic2Absolute(1, 1, GHYear + 1)) GHYear = GHYear + 1 Wend ' Search forward month by month from Muharram GHMonth = 1 While (Absolute > Islamic2Absolute(lastDayOfIslamicMonth(GHMonth, GHYear), GHMonth, GHYear)) GHMonth = GHMonth + 1 Wend GHDay = Absolute - Islamic2Absolute(1, GHMonth, GHYear) + 1 End If End Sub Private Function Islamic2Absolute(GHDay As Integer, GHMonth As Integer, GHYear As Integer) As Currency ' Computes the absolute date from the Islamic date. Islamic2Absolute = Int(CCur(GHDay) + 29 * (CCur(GHMonth) - 1) + Int(CCur(GHMonth) / 2) + 354 * (CCur(GHYear) - 1) + (3 + (11 * CCur(GHYear))) / 30 + IslamicEpoch) End Function Private Function lastDayOfIslamicMonth(GHMonth As Integer, GHYear As Integer) As Integer ' Last day in month during year on the Islamic calendar. lastDayOfIslamicMonth = IIf((GHMonth Mod 2 = 1) Or (GHMonth = 12 And IslamicLeapYear(GHYear)), 30, 29) End Function Private Function IslamicLeapYear(GHYear As Integer) As Boolean ' True if year is an Islamic leap year IslamicLeapYear = IIf(((((11 * GHYear) + 14) Mod 30) < 11), True, False) End Function
جهت استفاده از روال Gregorian2GhamariHijri استفاده نماييد.
Const IslamicEpoch = 227014 Public Sub Gregorian2GhamariHijri(ByVal GDay As Integer, ByVal GMonth As Integer, ByVal GYear As Integer, ByRef GHDay As Integer, ByRef GHMonth As Integer, ByRef GHYear As Integer) Call Absolute2Islamic(Gregorian2Absolute(GDay, GMonth, GYear), GHDay, GHMonth, GHYear) End Sub Private Function lastDayOfGregorianMonth(GMonth As Integer, GYear As Integer) As Integer ' Compute the last date of the month for the Gregorian calendar. If (GMonth = 2) Then If (GYear Mod 4 = 0 And GYear Mod 100 <> 0) Or (GYear Mod 400 = 0) Then lastDayOfGregorianMonth = 29 Exit Function End If End If Select Case GMonth Case 1 lastDayOfGregorianMonth = 31 Case 2 lastDayOfGregorianMonth = 28 Case 3 lastDayOfGregorianMonth = 31 Case 4 lastDayOfGregorianMonth = 30 Case 5 lastDayOfGregorianMonth = 31 Case 6 lastDayOfGregorianMonth = 30 Case 7 lastDayOfGregorianMonth = 31 Case 8 lastDayOfGregorianMonth = 31 Case 9 lastDayOfGregorianMonth = 30 Case 10 lastDayOfGregorianMonth = 31 Case 11 lastDayOfGregorianMonth = 30 Case 12 lastDayOfGregorianMonth = 31 End Select End Function Private Function Gregorian2Absolute(GDay As Integer, GMonth As Integer, GYear As Integer) As Currency ' Computes the absolute date from the Gregorian date. Dim N As Integer Dim m As Integer N = GDay ' days this month For m = GMonth - 1 To 1 Step -1 ' days in prior months this year N = N + lastDayOfGregorianMonth(m, GYear) Next Gregorian2Absolute = Int(N + 365 * (CCur(GYear) - 1) + (CCur(GYear) - 1) / 4 - (CCur(GYear) - 1) / 100 + (CCur(GYear) - 1) / 400) End Function Private Sub Absolute2Islamic(Absolute As Currency, GHDay As Integer, GHMonth As Integer, GHYear As Integer) ' Computes the Islamic date from the absolute date. If (Absolute <= IslamicEpoch) Then ' Date is pre-Islamic GHMonth = 0 GHDay = 0 GHYear = 0 Else ' Search forward year by year from approximate year GHYear = Int((Absolute - IslamicEpoch) / 355) While (Absolute >= Islamic2Absolute(1, 1, GHYear + 1)) GHYear = GHYear + 1 Wend ' Search forward month by month from Muharram GHMonth = 1 While (Absolute > Islamic2Absolute(lastDayOfIslamicMonth(GHMonth, GHYear), GHMonth, GHYear)) GHMonth = GHMonth + 1 Wend GHDay = Absolute - Islamic2Absolute(1, GHMonth, GHYear) + 1 End If End Sub Private Function Islamic2Absolute(GHDay As Integer, GHMonth As Integer, GHYear As Integer) As Currency ' Computes the absolute date from the Islamic date. Islamic2Absolute = Int(CCur(GHDay) + 29 * (CCur(GHMonth) - 1) + Int(CCur(GHMonth) / 2) + 354 * (CCur(GHYear) - 1) + (3 + (11 * CCur(GHYear))) / 30 + IslamicEpoch) End Function Private Function lastDayOfIslamicMonth(GHMonth As Integer, GHYear As Integer) As Integer ' Last day in month during year on the Islamic calendar. lastDayOfIslamicMonth = IIf((GHMonth Mod 2 = 1) Or (GHMonth = 12 And IslamicLeapYear(GHYear)), 30, 29) End Function Private Function IslamicLeapYear(GHYear As Integer) As Boolean ' True if year is an Islamic leap year IslamicLeapYear = IIf(((((11 * GHYear) + 14) Mod 30) < 11), True, False) End Function
جهت استفاده از روال Gregorian2GhamariHijri استفاده نماييد.
