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