Option Explicit
Public IdulFitri As Date
Public IdulFitri2 As Date
Public IdulAdha As Date
Public MaulidNabi As Date
Public TahunBaruHijri As Date
Public IsraMiraj As Date
Public TahunIdulFitri As Long
Public TahunHijriyah As Long
Public TahunIdulAdha As Long
Public TahunMaulid As Long
Public TahunIsraMiraj As Long
Private Function intPart(floatNum)
Dim lngReturn As Long
If floatNum < -0.0000001 Then
intPart = (floatNum - 0.0000001)
End If
intPart = Fix(floatNum + 0.0000001)
End Function
Private Function RoundDown(dblValue As Double) As Double
On Error GoTo PROC_ERR
Dim myDec As Long
myDec = InStr(1, CStr(dblValue), ".", vbTextCompare)
If myDec > 0 Then
RoundDown = CDbl(Left(CStr(dblValue), myDec))
Else
RoundDown = dblValue
End If
PROC_EXIT:
Exit Function
PROC_ERR:
MsgBox Err.Description, vbInformation, "Round Down"
End Function
Private Function RoundUp(dblValue As Double) As Double
On Error GoTo PROC_ERR
Dim myDec As Long
myDec = InStr(1, CStr(dblValue), ".", vbTextCompare)
If myDec > 0 Then
RoundUp = CDbl(Left(CStr(dblValue), myDec)) + 1
Else
RoundUp = dblValue
End If
PROC_EXIT:
Exit Function
PROC_ERR:
MsgBox Err.Description, vbInformation, "Round Up"
End Function
Private Function Trunc(dblValue As Double) As Long
On Error Resume Next
Dim strValue As String
If dblValue = 0 Then
Trunc = 0
Exit Function
End If
Dim myDec As Integer
Dim Pisah() As String
myDec = InStr(1, CStr(dblValue), ".", vbTextCompare)
If myDec <> 0 Then
Pisah = Split(CStr(dblValue), ".")
strValue = Pisah(0)
Else
strValue = dblValue
End If
Trunc = CLng(strValue)
End Function
Public Function Masehi2Hijri(datMasehi As Date) As Date
Dim dDay As Integer
Dim dMonth As Integer
Dim dYear As Long
Const intAW As Long = 227016
Dim intMonth As Integer
Dim intYear As Integer
Dim TA(0 To 12) As Integer
Dim JH(0 To 12) As Integer
Dim KA(0 To 12) As Integer
Dim intAM1 As Long
Dim intAM As Long
Dim intAH As Long
Dim intB As Integer
Dim intThH1 As Integer
Dim intDayCount As Integer
Dim intAddYear As Integer
Dim intTHM2 As Integer
Dim intSisa As Integer
Dim intModDay1 As Integer
Dim intModDay2 As Integer
Dim intBulan1 As Integer
Dim x As Integer
Dim intJmlHari As Integer
Dim intSisaHari As Integer
Dim dHijri As Integer
Dim mHijri As Integer
Dim yHijri As Integer
Dim intODay As Integer
Dim datResult As Date
dDay = Day(datMasehi)
dMonth = Month(datMasehi)
dYear = Year(datMasehi)
TA(0) = 29: TA(1) = 30
TA(2) = 29: TA(3) = 30
TA(4) = 29: TA(5) = 30
TA(6) = 29: TA(7) = 30
TA(8) = 29: TA(9) = 30
TA(10) = 29: TA(11) = 30
TA(12) = 29
KA(0) = 0: KA(1) = 2
KA(2) = 5: KA(3) = 7
KA(4) = 10: KA(5) = 13
KA(6) = 16: KA(7) = 18
KA(8) = 21: KA(9) = 24
KA(10) = 26: KA(11) = 29
KA(12) = 32
JH(0) = 0: JH(1) = 30
JH(2) = 59: JH(3) = 89
JH(4) = 118: JH(5) = 148
JH(6) = 177: JH(7) = 207
JH(8) = 236: JH(9) = 266
JH(10) = 295: JH(11) = 325
JH(12) = 354
intMonth = IIf(dMonth < 3, dMonth + 12, dMonth)
intYear = IIf(dMonth < 3, dYear - 1, dYear)
intAM1 = Int(365.25 * intYear) + _
Int(30.60001 * (intMonth + 1)) + dDay - 428
intB = IIf(intAM1 < 577748, 0, 2 - _
Int(intYear / 100) + Int(Int(intYear / 100) / 4))
intAM = Int(365.25 * intYear) + _
Int(30.60001 * (intMonth + 1)) + dDay + intB - 428
intAH = intAM - intAW
intThH1 = Int(intAH / 354.3671)
intModDay1 = Round(intAH - 354.3671 * Int(intAH / 354.3671), 0.5)
intModDay2 = RoundUp(intAH - 354.3671 * Int(intAH / 354.3671))
intDayCount = IIf(intAH < 0, intModDay1, intModDay2)
intAddYear = Int(intDayCount / 365)
intTHM2 = intThH1 + intAddYear + 1
intSisa = intDayCount Mod 365
For x = 1 To 12
If intSisa >= JH(x - 1) And intSisa <= JH(x) Then
intBulan1 = x - 1
Exit For
End If
Next
intJmlHari = JH(intBulan1)
intSisaHari = intSisa - intJmlHari
dHijri = IIf(intSisaHari = 0, TA(intBulan1), intSisaHari)
mHijri = IIf(intSisaHari = 0, intBulan1, _
IIf((intBulan1 + 1) Mod 12 = 0, 12, (intBulan1 + 1) Mod 12))
yHijri = intTHM2
datResult = DateSerial(yHijri, mHijri, dHijri)
Masehi2Hijri = datResult
End Function
Public Function Hijri2Masehi(datHijri As Date) As Date
Dim dDay As Integer
Dim dMonth As Integer
Dim dYear As Long
Dim datResult As Date
Const intAW As Long = 227016
dDay = Day(datHijri)
dMonth = Month(datHijri)
dYear = Year(datHijri)
Dim intAH As Long
Dim intAM As Long
intAH = Trunc((11 * dYear) / 30) + _
Trunc(354 * dYear) + _
Trunc(30 * dMonth) - _
Trunc((dMonth - 1) / 2) + dDay - 384
intAM = intAH + intAW
Dim intTHM1 As Long
Dim intDayCount As Integer
Dim intAddYear As Integer
Dim intTHM2 As Long
Dim intA As Integer
Dim intB As Integer
Dim intSisa As Integer
intTHM1 = Int(intAM / 1461) * 4
intDayCount = intAM Mod 1461
intAddYear = Int(intDayCount / 365)
intTHM2 = intTHM1 + intAddYear + 1
intA = intDayCount Mod 365
intB = IIf(intAM < 577748, 0, 2 - Int(intTHM2 / 100) + _
Int(Int(intTHM2 / 100) / 4))
intSisa = intA - intB
Dim JH(0 To 12) As Integer
Dim JLH(0 To 12) As Integer
Dim intBulan1 As Integer
Dim intMatch As Integer
Dim x As Integer
JH(0) = 31
JH(1) = 31
JH(2) = IIf((((intTHM2 Mod 4) = 0 Or (intTHM2 Mod 100) = 0) _
Or (intTHM2 Mod 400) = 0), 29, 28)
JH(3) = 31
JH(4) = 30
JH(5) = 31
JH(6) = 30
JH(7) = 31
JH(8) = 31
JH(9) = 30
JH(10) = 31
JH(11) = 30
JH(12) = 31
JLH(0) = 0
JLH(1) = 31
For x = 2 To 12
JLH(x) = JLH(x - 1) + JH(x)
Next
For x = 1 To 12
If intSisa >= JLH(x - 1) And intSisa <= JLH(x) Then
intMatch = x - 1
Exit For
End If
Next
intBulan1 = IIf(intSisa < 31, 0, intMatch)
Dim intJmlHari As Integer
Dim intSisaHari As Integer
intJmlHari = JLH(intBulan1)
intSisaHari = intSisa - intJmlHari
Dim dMasehi As Integer
Dim mMasehi As Integer
Dim yMasehi As Long
dMasehi = IIf(intSisaHari = 0, JH(intBulan1), intSisaHari)
mMasehi = IIf(intJmlHari = 0, intBulan1, _
IIf((intBulan1 + 1) Mod 12 = 0, 12, (intBulan1 + 1) Mod 12))
yMasehi = intTHM2
datResult = DateSerial(yMasehi, mMasehi, dMasehi)
Hijri2Masehi = datResult
End Function
Public Function Masehi2Hijri2(ByVal dDate As Date) As Date
Dim j, k, l, n, jd
Dim monthName As String
Dim intDay As Integer, intMonth As Integer, intYear As Integer
Dim arrFormat() As String
Dim sSplit As String
Dim strResult As String
Dim sDay As String
Dim sMonth As String
Dim sYear As String
intDay = Day(dDate)
intMonth = Month(dDate)
intYear = Year(dDate)
If ((intYear > 1582) Or ((intYear = 1582) And (intMonth > 10)) _
Or ((intYear = 1582) And (intMonth = 10) And (intDay > 14))) Then
jd = intPart((1461 * (intYear + 4800 + _
intPart((intMonth - 14) / 12))) / 4) + _
intPart((367 * (intMonth - 2 - 12 * _
(intPart((intMonth - 14) / 12)))) / 12) - _
intPart((3 * (intPart((intYear + 4900 + _
intPart((intMonth - 14) / 12)) / 100))) / 4) + intDay - 32075
Else
jd = 367 * intYear - intPart((7 * _
(intYear + 5001 + intPart((intMonth - 9) / 7))) / 4) + _
intPart((275 * intMonth) / 9) + intDay + 1729777
End If
l = jd - 1948440 + 10632
n = intPart((l - 1) / 10631)
l = l - 10631 * n + 354
j = (intPart((10985 - l) / 5316)) * (intPart((50 * l) / 17719)) + _
(intPart(l / 5670)) * (intPart((43 * l) / 15238))
l = l - (intPart((30 - j) / 15)) * (intPart((17719 * j) / 50)) - _
(intPart(j / 16)) * (intPart((15238 * j) / 43)) + 29
intMonth = intPart((24 * l) / 709)
intDay = l - intPart((709 * intMonth) / 24)
intYear = 30 * n + j - 30
Masehi2Hijri2 = DateSerial(intYear, intMonth, intDay)
End Function
Public Function Hijri2Pasaran(datHijri As Date) As String
Dim dDay As Integer
Dim dMonth As Integer
Dim dYear As Long
Dim intAH As Long
Dim intAM As Long
Dim datResult As Date
Dim PA(5) As String
Const intAW As Long = 227016
dDay = Day(datHijri)
dMonth = Month(datHijri)
dYear = Year(datHijri)
intAH = Trunc((11 * dYear) / 30) + _
Trunc(354 * dYear) + _
Trunc(30 * dMonth) - _
Trunc((dMonth - 1) / 2) + dDay - 384
intAM = intAH + intAW
PA(0) = "Wage"
PA(1) = "Kliwon"
PA(2) = "Legi"
PA(3) = "Pahing"
PA(4) = "Pon"
Dim intMod As Integer
intMod = intAM Mod 5
Hijri2Pasaran = PA(intMod)
End Function
Public Sub Islam(intTahun As Integer)
On Error Resume Next
Dim x As Integer
Dim dDate As Date
Dim datResult As Date
Dim datHijri(1 To 366) As Date
Dim datMasehi(1 To 366) As Date
For x = 0 To 366
dDate = DateAdd("d", x, DateSerial(intTahun, 1, 1))
datMasehi(x) = dDate
datHijri(x) = Masehi2Hijri(dDate)
If Hijri2Masehi(datHijri(x)) <> datMasehi(x) Then
datHijri(x) = Masehi2Hijri2(dDate)
End If
Select Case Month(datHijri(x))
Case 1
If Day(datHijri(x)) = 1 Then
TahunBaruHijri = datMasehi(x)
End If
TahunHijriyah = Year(datHijri(x))
Case 3
If Day(datHijri(x)) = 12 Then
MaulidNabi = datMasehi(x)
End If
TahunMaulid = Year(datHijri(x))
Case 7
If Day(datHijri(x)) = 27 Then
IsraMiraj = datMasehi(x)
End If
TahunIsraMiraj = Year(datHijri(x))
Case 10
If Day(datHijri(x)) = 1 Then
IdulFitri = datMasehi(x)
End If
If Day(datHijri(x)) = 2 Then
IdulFitri2 = datMasehi(x)
End If
TahunIdulFitri = Year(datHijri(x))
Case 12
If Day(datHijri(x)) = 10 Then
IdulAdha = datMasehi(x)
End If
TahunIdulAdha = Year(datHijri(x))
End Select
Next
End Sub
