Ampiran Visual Basic 6

Menghitung Hari Libur Keagamaan

1 Februari 2012 3 Komentar

Jika sebelumnya saya telah membagikan sebuah aplikasi Kalender Indonesia yang dilengkapi dengan hari-hari libur nasional dan keagamaan, dan prakiraan cuti bersama. Nah kali ini saya akan membahasa perumusan untuk menghitung hari libur nasional dan keagamaan yang berlaku di Indonesia.

Ayo, langsung saja ke prakteknya. Jalankan IDE VB6 Anda, buat sebuah project baru, kemudian tambahkan beberapa module pada project Anda, diantaranya:
- basIslam
- basKristen
- basHindu
- basBuddha
- basChina
- basNasional

Oke, tinggal menyalin kode yang berikut ini:

- basIslam

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)
            'If Hijri2Masehi(datHijri(x)) <> datMasehi(x) Then
                'datHijri(x) = DateAdd("d", -1, Masehi2Hijri(dDate))
            'End If
        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

- basKristen

Option Explicit

Public Paskah As Date
Public WafatIsa As Date
Public KenaikanIsa As Date
Public Natal As Date
Public TahunBaru As Date

Sub Kristen(intTahun As Integer)
    Dim intA As Integer
    Dim intB As Integer
    Dim intC As Integer
    Dim intD As Integer
    Dim intE As Integer
    Dim intF As Integer
    Dim intG As Integer
    Dim intH As Integer
    Dim intI As Integer
    Dim intJ As Integer
    Dim intK As Integer
    Dim intL As Integer
    Dim intM As Integer
    Dim intN As Integer
    Dim intO As Integer
    
    intA = intTahun Mod 19
    intB = intTahun Mod 4
    intC = intTahun Mod 7
    
    intH = IIf((intTahun >= 1900 And intTahun <= 2099), 5, 0)
    intI = IIf((intTahun >= 2100 And intTahun <= 2199), 6, 0)
    intJ = IIf((intTahun >= 2200 And intTahun <= 2299), 0, 0)
    intK = intH + intI + intJ
    intL = IIf((intTahun >= 1900 And intTahun <= 2099), 24, 0)
    intM = IIf((intTahun >= 2100 And intTahun <= 2199), 24, 0)
    intN = IIf((intTahun >= 2200 And intTahun <= 2299), 25, 0)
    intO = intL + intM + intN
    
    intD = ((19 * intA) + intO) Mod 30
    intE = ((2 * intB) + (4 * intC) + (6 * intD) + intK) Mod 7
    intF = IIf(intD + intE < 10, 3, 4)
    intG = IIf(intD + intE < 10, intD + intE + 22, intD + intE - 9)
    
    Paskah = DateSerial(intTahun, intF, intG)
    WafatIsa = DateAdd("d", -2, Paskah)
    KenaikanIsa = DateAdd("d", 39, Paskah)
    TahunBaru = DateSerial(intTahun, 1, 1)
    Natal = DateSerial(intTahun, 12, 25)
End Sub

- basHindu

Option Explicit

Public Nyepi As Date

Public Sub Hindu(iTahun As Integer)
    Dim TA(1 To 33) As Integer
    Const cTanggal As Integer = 28
    Const cBulan As Integer = 3

    Dim intBulan As Integer
    Dim intTahun As Integer
    Dim intAM1 As Long
    Dim intKoreksiGr As Long
    Dim intH As Long
    Dim intN As Long
    Dim intI As Integer
    Dim Ma As Integer
    Dim Mb As Integer
    Dim MbMin As Integer
    
    Dim cDateFull As Date
    
    Dim Ya As Integer
    Dim Yb As Integer

    Dim x As Integer
    
    Dim datMa As Date
    Dim datMb As Date
    
    Dim datA1 As Date
    Dim datA2 As Date
        
    Dim lngMa As Long
    Dim lngMb As Long
    
    Dim intResult As Long
    Dim datResult As Date
    
    TA(1) = 0:    TA(2) = 30
    TA(3) = 60:    TA(4) = 89
    TA(5) = 119:    TA(6) = 148
    TA(7) = 178:    TA(8) = 207
    TA(9) = 237:    TA(10) = 266
    TA(11) = 296:    TA(12) = 325
    TA(13) = 355:    TA(14) = 384
    TA(15) = 414:    TA(16) = 443
    TA(17) = 473:    TA(18) = 502
    TA(19) = 532:    TA(20) = 562
    TA(21) = 591:    TA(22) = 621
    TA(23) = 650:    TA(24) = 680
    TA(25) = 709:    TA(26) = 739
    TA(27) = 768:    TA(28) = 798
    TA(29) = 827:    TA(30) = 857
    TA(31) = 886:    TA(32) = 916
    TA(33) = 945
    
    If cBulan < 3 Then
        intBulan = cBulan + 12
    Else
        intBulan = cBulan
    End If
    
    If intBulan < 3 Then
        intTahun = iTahun - 1
    Else
        intTahun = iTahun
    End If
    
    intAM1 = Int(365.25 * intTahun) + _
    Int(30.60001 * (intBulan + 1)) + cTanggal - 428
    
    If intAM1 < 577748 Then
        intKoreksiGr = 0
    Else
        intKoreksiGr = 2 - Int(intTahun / 100) + _
        Int(Int(intTahun / 100) / 4)
    End If
    
    intH = Int(365.25 * intTahun) + _
    Int(30.60001 * (intBulan + 1)) + cTanggal + _
    intKoreksiGr - 428
    
    intN = intH Mod 945
    
    If intN < 351 Then
        intI = (intN + 945) - 351
    Else
        intI = intN - 351
    End If
    
    For x = 1 To 33
        If TA(x) >= intI Then
            Ya = TA(x)
            Yb = TA(x - 1)
            Exit For
        End If
    Next
    
    datA1 = DateSerial(iTahun, 3, 31)
    datA2 = DateSerial(iTahun, 3, 2)
    
    Ma = Ya - intI + 1
    Mb = intI - Yb - 1
    
    MbMin = Mb + 1
    
    cDateFull = DateSerial(intTahun, intBulan, cTanggal)
    
    datMa = DateAdd("d", Ma - 1, cDateFull)
    datMb = DateAdd("d", -MbMin, cDateFull)
    
    lngMa = IIf(datMa >= datA1, 0, CLng(datMa))
    lngMb = IIf(datMb >= datA2, CLng(datMb), 0)
    
    intResult = lngMa + lngMb
    
    datResult = CDate(intResult)
    
    Nyepi = datResult
End Sub

- basBuddha

Option Explicit

Public Waisak As Date

Private Function iMod(dblValue1, dblValue2) As Double
On Error Resume Next
    iMod = dblValue1 - dblValue2 * Int(dblValue1 / dblValue2)
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 Sub Buddha(iTahun As Integer)
    Dim intIJST(1 To 2) As Integer
    Dim intTanggal(1 To 2) As Integer
    Dim intBulan(1 To 2) As Integer
    Dim intTahun(1 To 2) As Integer
    
    Dim intTa1(1 To 2) As Integer
    Dim intTa2(1 To 2) As Integer
    Dim intTa3(1 To 2) As Integer
    
    Const PI As Double = 3.141592654
    
    Dim dblKN(1 To 2) As Double
    Dim dblKB(1 To 2) As Double
    Dim dblT(1 To 2) As Double
    
    Dim dblK1(1 To 2) As Double
    Dim dblK2(1 To 2) As Double
    Dim dblK3(1 To 2) As Double
    Dim dblK4(1 To 2) As Double
    Dim dblK5(1 To 2) As Double
    Dim dblK6(1 To 2) As Double
    Dim dblK7(1 To 2) As Double
    
    Dim dblM(1 To 2) As Double
    Dim dblM1(1 To 2) As Double
    Dim dblM2(1 To 2) As Double
    Dim dblM3(1 To 2) As Double
    
    Dim dblMA(1 To 2) As Double
    Dim dblMA1(1 To 2) As Double
    Dim dblMA2(1 To 2) As Double
    Dim dblMA3(1 To 2) As Double
        
    Dim dblF(1 To 2) As Double
    Dim dblF1(1 To 2) As Double
    Dim dblF2(1 To 2) As Double
    Dim dblF3(1 To 2) As Double
    
    Dim dblKRA1(1 To 2) As Double
    Dim dblKRA2(1 To 2) As Double
    Dim dblKRA3(1 To 2) As Double
    Dim dblKRA4(1 To 2) As Double
    Dim dblKRA5(1 To 2) As Double
    Dim dblKRA6(1 To 2) As Double
    Dim dblKORA(1 To 2) As Double
    
    Dim dblKRB1(1 To 2) As Double
    Dim dblKRB2(1 To 2) As Double
    Dim dblKRB3(1 To 2) As Double
    Dim dblKRB4(1 To 2) As Double
    Dim dblKRB5(1 To 2) As Double
    Dim dblKORB(1 To 2) As Double
    Dim dblKORB1(1 To 2) As Double
    
    Dim dblKC1(1 To 2) As Double
    Dim dblKC2(1 To 2) As Double
    Dim dblKC3(1 To 2) As Double
    Dim dblKORC(1 To 2) As Double
    Dim dblKORC1(1 To 2) As Double
    
    Dim dblKoreksi(1 To 2) As Double
    
    Dim dblJdA1(1 To 2) As Double
    Dim dblJdA2(1 To 2) As Double
    Dim dblJdA3(1 To 2) As Double
    
    Dim dblJdB1(1 To 2) As Double
    Dim dblJdB2(1 To 2) As Double
    Dim dblJdB3(1 To 2) As Double
    
    Dim dblJdC1(1 To 2) As Double
    Dim dblJdC2(1 To 2) As Double
    Dim dblJdC3(1 To 2) As Double
    
    Dim dblJD(1 To 2) As Double
    
    Dim dblZJd(1 To 2) As Double
    Dim dblEFJd(1 To 2) As Double
    Dim dblAPJd(1 To 2) As Double
    Dim dblAJd(1 To 2) As Double
    Dim dblBJd(1 To 2) As Double
    Dim dblCJd(1 To 2) As Double
    Dim dblDJd(1 To 2) As Double
    Dim dblEJd(1 To 2) As Double
    
    Dim dblHasilJam(1 To 2) As Double
    Dim dblHasilBulan(1 To 2) As Integer
    Dim dblHasilTahun(1 To 2) As Integer
    Dim dblHasilHari(1 To 2) As Integer
    Dim dblHasilPasaran(1 To 2) As Integer
    
    Dim dblTgl1(1 To 2) As Double
    Dim dblTgl2(1 To 2) As Double
    Dim dblTgl3(1 To 2) As Double
    Dim dblTgl4(1 To 2) As Double
    Dim dblTgl5(1 To 2) As Double
    Dim dblTglM(1 To 2) As Double
    
    Dim dblKT(1 To 2) As Double
    Dim dblET1(1 To 2) As Double
    Dim dblET2(1 To 2) As Double
    Dim dblKET(1 To 2) As Double
    
    Dim dblJDH(1 To 2) As Double
    
    Dim datFull(1 To 2) As Date
    Dim datHasil(1 To 2) As Date
        
    intIJST(1) = 0
    intTanggal(1) = 5
    intBulan(1) = 5
    intTahun(1) = iTahun
    
    datFull(1) = DateSerial(intTahun(1), intBulan(1), intTanggal(1))
    
    intTa1(1) = IIf((intTahun(1) Mod 4) = 0, 1, 0)
    intTa2(1) = IIf((intTahun(1) Mod 100) = 0, 1, 0)
    intTa3(1) = intTa1(1) + intTa2(1)
    
    dblKB(1) = IIf(intTa3(1) > 0, 1, 2)
    
    dblK1(1) = Trunc((275 * intBulan(1)) / 9)
    dblK2(1) = Trunc((intBulan(1) + 9) / 12) * dblKB(1)
    dblK3(1) = (dblK1(1) - dblK2(1) + intTanggal(1) - 30)
    dblK4(1) = (dblK3(1) / 365.25) + (intTahun(1) - 1900)
    dblK5(1) = (dblK4(1) * 12.3685)
    dblK6(1) = (dblK5(1) - Trunc(dblK5(1)))
    dblK7(1) = IIf(dblK6(1) > 0.5, Trunc(dblK5(1) + 1), Trunc(dblK5(1) + 0))
    
    dblKN(1) = IIf(intIJST(1) = 1, (dblK7(1) - 0), (dblK7(1) - 0.5))
    dblT(1) = (dblKN(1) / 1236.85)
    
    dblM1(1) = 29.10535608 * dblKN(1)
    dblM2(1) = -0.000033 * dblT(1) * dblT(1)
    dblM3(1) = -0.00000347 * dblT(1) * dblT(1) * dblT(1)
    dblM(1) = iMod(359.2242 + dblM1(1) + dblM2(1) + dblM3(1), 360)
    
    dblMA1(1) = 385.81691806 * dblKN(1)
    dblMA2(1) = 0.0107306 * dblT(1) * dblT(1)
    dblMA3(1) = 0.00001236 * dblT(1) * dblT(1) * dblT(1)
    dblMA(1) = iMod(306.0253 + dblMA1(1) + dblMA2(1) + dblMA3(1), 360)
    
    dblF1(1) = 390.67050646 * dblKN(1)
    dblF2(1) = -0.0016528 * dblT(1) * dblT(1)
    dblF3(1) = -0.00000239 * dblT(1) * dblT(1) * dblT(1)
    dblF(1) = iMod(21.2964 + dblF1(1) + dblF2(1) + dblF3(1), 360)
    
    dblKRA1(1) = 0.1734 - (0.000393 * dblT(1))
    dblKRA2(1) = (dblKRA1(1) * Sin(dblM(1) * PI / 180))
    dblKRA3(1) = -0.4068 * Sin(dblMA(1) * PI / 180)
    dblKRA4(1) = 0.0021 * Sin(2 * dblM(1) * PI / 180)
    dblKRA5(1) = 0.0161 * Sin(2 * dblMA(1) * PI / 180)
    dblKRA6(1) = -0.0004 * Sin(3 * dblMA(1) * PI / 180)
    dblKORA(1) = (dblKRA2(1) + dblKRA3(1) + dblKRA4(1) + dblKRA5(1) + dblKRA6(1))
    
    dblKRB1(1) = -0.0051 * Sin((dblM(1) + dblMA(1)) * PI / 180)
    dblKRB2(1) = -0.0074 * Sin((dblM(1) - dblMA(1)) * PI / 180)
    dblKRB3(1) = 0.0004 * Sin((2 * dblF(1) + dblM(1)) * PI / 180)
    dblKRB4(1) = -0.0004 * Sin((2 * dblF(1) - dblM(1)) * PI / 180)
    dblKRB5(1) = 0.0104 * Sin(2 * dblF(1) * PI / 180)
    dblKORB(1) = (dblKRB1(1) + dblKRB2(1) + dblKRB3(1) + dblKRB4(1) + dblKRB5(1))
    dblKORB1(1) = -0.0051 * Sin((dblM(1) + dblMA(1)) * PI / 180) + _
                  -0.0074 * Sin((dblM(1) - dblMA(1)) * PI / 180) + _
                  0.0004 * Sin((2 * dblF(1) + dblM(1)) * PI / 180) + _
                  -0.0004 * Sin((2 * dblF(1) - dblM(1)) * PI / 180) + _
                  0.0104 * Sin(2 * dblF(1) * PI / 180)
    
    dblKC1(1) = -0.0006 * Sin((2 * dblF(1) + dblMA(1)) * PI / 180)
    dblKC2(1) = 0.001 * Sin((2 * dblF(1) - dblMA(1)) * PI / 180)
    dblKC3(1) = 0.0005 * Sin((dblM(1) + 2 * dblMA(1)) * PI / 180)
    dblKORC(1) = (dblKC1(1) + dblKC2(1) + dblKC3(1))
    dblKORC1(1) = -0.0006 * Sin((2 * dblF(1) + dblMA(1)) * PI / 180) + _
                  0.001 * Sin((2 * dblF(1) - dblMA(1)) * PI / 180) + _
                  0.0005 * Sin((dblM(1) + 2 * dblMA(1)) * PI / 180)
    
    dblKoreksi(1) = (dblKORA(1) + dblKORB(1) + dblKORC(1))
    
    dblJdA1(1) = 29.53058868 * dblKN(1)
    dblJdA2(1) = 0.0001178 * dblT(1) * dblT(1) * dblT(1)
    dblJdA3(1) = -0.000000155 * dblT(1) * dblT(1) * dblT(1)
    
    dblJdB1(1) = 132.87 * dblT(1)
    dblJdB2(1) = 0.009173 * dblT(1) * dblT(1)
    dblJdB3(1) = 166.56 + dblJdB1(1) - dblJdB2(1)
    
    dblJdC1(1) = 0.00033 * Sin(dblJdB3(1) * PI / 180)
    dblJdC2(1) = (dblJdA1(1) + dblJdA2(1) + dblJdA3(1) + dblJdC1(1))
    dblJdC3(1) = 2415020.75933 + dblJdC2(1)
    dblJD(1) = (dblJdC3(1) + 0.5 + dblKoreksi(1))
    
    dblZJd(1) = Trunc(dblJD(1))
    dblEFJd(1) = (dblJD(1) - dblZJd(1))
    dblAPJd(1) = Trunc((dblZJd(1) - 1867216.25) / 36524.25)
    dblAJd(1) = IIf(dblZJd(1) < 2299161, dblZJd(1), dblZJd(1) + 1 + dblAPJd(1) - Trunc(dblAPJd(1) / 4))
    dblBJd(1) = (dblAJd(1) + 1524)
    dblCJd(1) = Trunc((dblBJd(1) - 122.1) / 365.25)
    dblDJd(1) = Trunc(365.25 * dblCJd(1))
    dblEJd(1) = Trunc((dblBJd(1) - dblDJd(1)) / 30.6001)
    
    dblTgl1(1) = (dblBJd(1) - dblDJd(1) - Trunc(30.6001 * dblEJd(1)) + dblEFJd(1))
    dblTgl2(1) = Trunc(dblTgl1(1))
    dblTgl3(1) = (dblTgl1(1) - dblTgl2(1))
    dblTgl4(1) = (dblTgl3(1) * 24)
    dblTgl5(1) = (dblTgl4(1) + 7)
    dblTglM(1) = IIf(dblTgl5(1) <= 24, dblTgl2(1), dblTgl2(1) + 1)
    
    dblKT(1) = (dblK4(1) - 100) / 100
    dblET1(1) = 123.5 * dblKT(1)
    dblET2(1) = 32.5 * dblKT(1) * dblKT(1)
    dblKET(1) = (102.3 + dblET1(1) + dblET2(1)) / 3600
    
    dblJDH(1) = IIf(dblTgl5(1) <= 24, (dblZJd(1) + 2), dblZJd(1) + 3)
    
    dblHasilBulan(1) = IIf(dblEJd(1) < 13.5, dblEJd(1) - 1, dblEJd(1) - 13)
    dblHasilTahun(1) = IIf(dblHasilBulan(1) < 2.5, Trunc(dblCJd(1) - 4715), Trunc(dblCJd(1) - 4716))
    dblHasilHari(1) = (dblJDH(1) - Trunc(dblJDH(1) / 7) * 7)
    dblHasilPasaran(1) = (dblJDH(1) - Trunc(dblJDH(1) / 5) * 5)
    dblHasilJam(1) = IIf(dblTgl5(1) > 24, (dblTgl5(1) - 24), dblTgl5(1))
    
    
    'Tabel 2
    datHasil(1) = DateSerial(dblHasilTahun(1), dblHasilBulan(1), dblTglM(1))
    datFull(2) = IIf(datHasil(1) > datFull(1), datHasil(1), datHasil(1) + 29)
    
    intIJST(2) = 0
    intTanggal(2) = Day(datFull(2))
    intBulan(2) = Month(datFull(2))
    intTahun(2) = Year(datFull(2))
    
    intTa1(2) = IIf((intTahun(2) Mod 4) = 0, 1, 0)
    intTa2(2) = IIf((intTahun(2) Mod 100) = 0, 1, 0)
    intTa3(2) = intTa1(2) + intTa2(2)
    
    dblKB(2) = IIf(intTa3(2) > 0, 1, 2)
    
    '===========================================================================
    
    dblK1(2) = Trunc((275 * intBulan(2)) / 9)
    dblK2(2) = Trunc((intBulan(2) + 9) / 12) * dblKB(2)
    dblK3(2) = (dblK1(2) - dblK2(2) + intTanggal(2) - 30)
    dblK4(2) = (dblK3(2) / 365.25) + (intTahun(2) - 1900)
    dblK5(2) = (dblK4(2) * 12.3685)
    dblK6(2) = (dblK5(2) - Trunc(dblK5(2)))
    dblK7(2) = IIf(dblK6(2) > 0.5, Trunc(dblK5(2) + 1), Trunc(dblK5(2) + 0))
    
    dblKN(2) = IIf(intIJST(2) = 1, (dblK7(2) - 0), (dblK7(2) - 0.5))
    dblT(2) = (dblKN(2) / 1236.85)
    
    dblM1(2) = 29.10535608 * dblKN(2)
    dblM2(2) = -0.000033 * dblT(2) * dblT(2)
    dblM3(2) = -0.00000347 * dblT(2) * dblT(2) * dblT(2)
    dblM(2) = iMod(359.2242 + dblM1(2) + dblM2(2) + dblM3(2), 360)
    
    dblMA1(2) = 385.81691806 * dblKN(2)
    dblMA2(2) = 0.0107306 * dblT(2) * dblT(2)
    dblMA3(2) = 0.00001236 * dblT(2) * dblT(2) * dblT(2)
    dblMA(2) = iMod(306.0253 + dblMA1(2) + dblMA2(2) + dblMA3(2), 360)
    
    dblF1(2) = 390.67050646 * dblKN(2)
    dblF2(2) = -0.0016528 * dblT(2) * dblT(2)
    dblF3(2) = -0.00000239 * dblT(2) * dblT(2) * dblT(2)
    dblF(2) = iMod(21.2964 + dblF1(2) + dblF2(2) + dblF3(2), 360)
    
    dblKRA1(2) = 0.1734 - (0.000393 * dblT(2))
    dblKRA2(2) = (dblKRA1(2) * Sin(dblM(2) * PI / 180))
    dblKRA3(2) = -0.4068 * Sin(dblMA(2) * PI / 180)
    dblKRA4(2) = 0.0021 * Sin(2 * dblM(2) * PI / 180)
    dblKRA5(2) = 0.0161 * Sin(2 * dblMA(2) * PI / 180)
    dblKRA6(2) = -0.0004 * Sin(3 * dblMA(2) * PI / 180)
    dblKORA(2) = (dblKRA2(2) + dblKRA3(2) + dblKRA4(2) + dblKRA5(2) + dblKRA6(2))
    
    dblKRB1(2) = -0.0051 * Sin((dblM(2) + dblMA(2)) * PI / 180)
    dblKRB2(2) = -0.0074 * Sin((dblM(2) - dblMA(2)) * PI / 180)
    dblKRB3(2) = 0.0004 * Sin((2 * dblF(2) + dblM(2)) * PI / 180)
    dblKRB4(2) = -0.0004 * Sin((2 * dblF(2) - dblM(2)) * PI / 180)
    dblKRB5(2) = 0.0104 * Sin(2 * dblF(2) * PI / 180)
    dblKORB(2) = (dblKRB1(2) + dblKRB2(2) + dblKRB3(2) + dblKRB4(2) + dblKRB5(2))
    dblKORB1(2) = -0.0051 * Sin((dblM(2) + dblMA(2)) * PI / 180) + _
                  -0.0074 * Sin((dblM(2) - dblMA(2)) * PI / 180) + _
                  0.0004 * Sin((2 * dblF(2) + dblM(2)) * PI / 180) + _
                  -0.0004 * Sin((2 * dblF(2) - dblM(2)) * PI / 180) + _
                  0.0104 * Sin(2 * dblF(2) * PI / 180)
    
    dblKC1(2) = -0.0006 * Sin((2 * dblF(2) + dblMA(2)) * PI / 180)
    dblKC2(2) = 0.001 * Sin((2 * dblF(2) - dblMA(2)) * PI / 180)
    dblKC3(2) = 0.0005 * Sin((dblM(2) + 2 * dblMA(2)) * PI / 180)
    dblKORC(2) = (dblKC1(2) + dblKC2(2) + dblKC3(2))
    dblKORC1(2) = -0.0006 * Sin((2 * dblF(2) + dblMA(2)) * PI / 180) + _
                  0.001 * Sin((2 * dblF(2) - dblMA(2)) * PI / 180) + _
                  0.0005 * Sin((dblM(2) + 2 * dblMA(2)) * PI / 180)
    
    dblKoreksi(2) = (dblKORA(2) + dblKORB(2) + dblKORC(2))
    
    dblJdA1(2) = 29.53058868 * dblKN(2)
    dblJdA2(2) = 0.0001178 * dblT(2) * dblT(2) * dblT(2)
    dblJdA3(2) = -0.000000155 * dblT(2) * dblT(2) * dblT(2)
    
    dblJdB1(2) = 132.87 * dblT(2)
    dblJdB2(2) = 0.009173 * dblT(2) * dblT(2)
    dblJdB3(2) = 166.56 + dblJdB1(2) - dblJdB2(2)
    
    dblJdC1(2) = 0.00033 * Sin(dblJdB3(2) * PI / 180)
    dblJdC2(2) = (dblJdA1(2) + dblJdA2(2) + dblJdA3(2) + dblJdC1(2))
    dblJdC3(2) = 2415020.75933 + dblJdC2(2)
    dblJD(2) = (dblJdC3(2) + 0.5 + dblKoreksi(2))
    
    dblZJd(2) = Trunc(dblJD(2))
    dblEFJd(2) = (dblJD(2) - dblZJd(2))
    dblAPJd(2) = Trunc((dblZJd(2) - 1867216.25) / 36524.25)
    dblAJd(2) = IIf(dblZJd(2) < 2299161, dblZJd(2), dblZJd(2) + 1 + dblAPJd(2) - Trunc(dblAPJd(2) / 4))
    dblBJd(2) = (dblAJd(2) + 1524)
    dblCJd(2) = Trunc((dblBJd(2) - 122.1) / 365.25)
    dblDJd(2) = Trunc(365.25 * dblCJd(2))
    dblEJd(2) = Trunc((dblBJd(2) - dblDJd(2)) / 30.6001)
    
    dblTgl1(2) = (dblBJd(2) - dblDJd(2) - Trunc(30.6001 * dblEJd(2)) + dblEFJd(2))
    dblTgl2(2) = Trunc(dblTgl1(2))
    dblTgl3(2) = (dblTgl1(2) - dblTgl2(2))
    dblTgl4(2) = (dblTgl3(2) * 24)
    dblTgl5(2) = (dblTgl4(2) + 7)
    dblTglM(2) = IIf(dblTgl5(2) <= 24, dblTgl2(2), dblTgl2(2) + 1)
    
    dblKT(2) = (dblK4(2) - 100) / 100
    dblET1(2) = 123.5 * dblKT(2)
    dblET2(2) = 32.5 * dblKT(2) * dblKT(2)
    dblKET(2) = (102.3 + dblET1(2) + dblET2(2)) / 3600
    
    dblJDH(2) = IIf(dblTgl5(2) <= 24, (dblZJd(2) + 2), dblZJd(2) + 3)
    
    dblHasilBulan(2) = IIf(dblEJd(2) < 13.5, dblEJd(2) - 1, dblEJd(2) - 13)
    dblHasilTahun(2) = IIf(dblHasilBulan(2) < 2.5, Trunc(dblCJd(2) - 4715), Trunc(dblCJd(2) - 4716))
    dblHasilHari(2) = (dblJDH(2) - Trunc(dblJDH(2) / 7) * 7)
    dblHasilPasaran(2) = (dblJDH(2) - Trunc(dblJDH(2) / 5) * 5)
    dblHasilJam(2) = IIf(dblTgl5(2) > 24, (dblTgl5(2) - 24), dblTgl5(2))
    
    datHasil(2) = DateSerial(dblHasilTahun(2), dblHasilBulan(2), dblTglM(2))
    
    Waisak = datHasil(2)
End Sub

- basChina

Option Explicit

Public Imlek As Date
Public Shio As String

Private Function iMod(dblValue1, dblValue2) As Double
On Error Resume Next
    iMod = dblValue1 - dblValue2 * Int(dblValue1 / dblValue2)
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 Sub China(iTahun As Integer)
    Dim intIJST(1 To 2) As Integer
    Dim intTanggal(1 To 2) As Integer
    Dim intBulan(1 To 2) As Integer
    Dim intTahun(1 To 2) As Integer
    
    Dim intTa1(1 To 2) As Integer
    Dim intTa2(1 To 2) As Integer
    Dim intTa3(1 To 2) As Integer
    
    Const PI As Double = 3.141592654
    
    Dim dblKN(1 To 2) As Double
    Dim dblKB(1 To 2) As Double
    Dim dblT(1 To 2) As Double
    
    Dim dblK1(1 To 2) As Double
    Dim dblK2(1 To 2) As Double
    Dim dblK3(1 To 2) As Double
    Dim dblK4(1 To 2) As Double
    Dim dblK5(1 To 2) As Double
    Dim dblK6(1 To 2) As Double
    Dim dblK7(1 To 2) As Double
    
    Dim dblM(1 To 2) As Double
    Dim dblM1(1 To 2) As Double
    Dim dblM2(1 To 2) As Double
    Dim dblM3(1 To 2) As Double
    
    Dim dblMA(1 To 2) As Double
    Dim dblMA1(1 To 2) As Double
    Dim dblMA2(1 To 2) As Double
    Dim dblMA3(1 To 2) As Double
        
    Dim dblF(1 To 2) As Double
    Dim dblF1(1 To 2) As Double
    Dim dblF2(1 To 2) As Double
    Dim dblF3(1 To 2) As Double
    
    Dim dblKRA1(1 To 2) As Double
    Dim dblKRA2(1 To 2) As Double
    Dim dblKRA3(1 To 2) As Double
    Dim dblKRA4(1 To 2) As Double
    Dim dblKRA5(1 To 2) As Double
    Dim dblKRA6(1 To 2) As Double
    Dim dblKORA(1 To 2) As Double
    
    Dim dblKRB1(1 To 2) As Double
    Dim dblKRB2(1 To 2) As Double
    Dim dblKRB3(1 To 2) As Double
    Dim dblKRB4(1 To 2) As Double
    Dim dblKRB5(1 To 2) As Double
    Dim dblKORB(1 To 2) As Double
    Dim dblKORB1(1 To 2) As Double
    
    Dim dblKC1(1 To 2) As Double
    Dim dblKC2(1 To 2) As Double
    Dim dblKC3(1 To 2) As Double
    Dim dblKORC(1 To 2) As Double
    Dim dblKORC1(1 To 2) As Double
    
    Dim dblKoreksi(1 To 2) As Double
    
    Dim dblJdA1(1 To 2) As Double
    Dim dblJdA2(1 To 2) As Double
    Dim dblJdA3(1 To 2) As Double
    
    Dim dblJdB1(1 To 2) As Double
    Dim dblJdB2(1 To 2) As Double
    Dim dblJdB3(1 To 2) As Double
    
    Dim dblJdC1(1 To 2) As Double
    Dim dblJdC2(1 To 2) As Double
    Dim dblJdC3(1 To 2) As Double
    
    Dim dblJD(1 To 2) As Double
    
    Dim dblZJd(1 To 2) As Double
    Dim dblEFJd(1 To 2) As Double
    Dim dblAPJd(1 To 2) As Double
    Dim dblAJd(1 To 2) As Double
    Dim dblBJd(1 To 2) As Double
    Dim dblCJd(1 To 2) As Double
    Dim dblDJd(1 To 2) As Double
    Dim dblEJd(1 To 2) As Double
    
    Dim dblHasilJam(1 To 2) As Double
    Dim dblHasilBulan(1 To 2) As Integer
    Dim dblHasilTahun(1 To 2) As Integer
    Dim dblHasilHari(1 To 2) As Integer
    Dim dblHasilPasaran(1 To 2) As Integer
    
    Dim dblTgl1(1 To 2) As Double
    Dim dblTgl2(1 To 2) As Double
    Dim dblTgl3(1 To 2) As Double
    Dim dblTgl4(1 To 2) As Double
    Dim dblTgl5(1 To 2) As Double
    Dim dblTglM(1 To 2) As Double
    
    Dim dblKT(1 To 2) As Double
    Dim dblET1(1 To 2) As Double
    Dim dblET2(1 To 2) As Double
    Dim dblKET(1 To 2) As Double
    
    Dim dblJDH(1 To 2) As Double
    
    Dim datFull(1 To 2) As Date
    Dim datHasil(1 To 2) As Date
        
    intIJST(1) = 1
    intTanggal(1) = 22
    intBulan(1) = 12
    intTahun(1) = iTahun - 1
    
    datFull(1) = DateSerial(intTahun(1), intBulan(1), intTanggal(1))
    
    intTa1(1) = IIf((intTahun(1) Mod 4) = 0, 1, 0)
    intTa2(1) = IIf((intTahun(1) Mod 100) = 0, 1, 0)
    intTa3(1) = intTa1(1) + intTa2(1)
    
    dblKB(1) = IIf(intTa3(1) > 0, 1, 2)
    
    dblK1(1) = Trunc((275 * intBulan(1)) / 9)
    dblK2(1) = Trunc((intBulan(1) + 9) / 12) * dblKB(1)
    dblK3(1) = (dblK1(1) - dblK2(1) + intTanggal(1) - 30)
    dblK4(1) = (dblK3(1) / 365.25) + (intTahun(1) - 1900)
    dblK5(1) = (dblK4(1) * 12.3685)
    dblK6(1) = (dblK5(1) - Trunc(dblK5(1)))
    dblK7(1) = IIf(dblK6(1) > 0.5, Trunc(dblK5(1) + 1), Trunc(dblK5(1) + 0))
    
    dblKN(1) = IIf(intIJST(1) = 1, (dblK7(1) - 0), (dblK7(1) - 0.5))
    dblT(1) = (dblKN(1) / 1236.85)
    
    dblM1(1) = 29.10535608 * dblKN(1)
    dblM2(1) = -0.000033 * dblT(1) * dblT(1)
    dblM3(1) = -0.00000347 * dblT(1) * dblT(1) * dblT(1)
    dblM(1) = iMod(359.2242 + dblM1(1) + dblM2(1) + dblM3(1), 360)
    
    dblMA1(1) = 385.81691806 * dblKN(1)
    dblMA2(1) = 0.0107306 * dblT(1) * dblT(1)
    dblMA3(1) = 0.00001236 * dblT(1) * dblT(1) * dblT(1)
    dblMA(1) = iMod(306.0253 + dblMA1(1) + dblMA2(1) + dblMA3(1), 360)
    
    dblF1(1) = 390.67050646 * dblKN(1)
    dblF2(1) = -0.0016528 * dblT(1) * dblT(1)
    dblF3(1) = -0.00000239 * dblT(1) * dblT(1) * dblT(1)
    dblF(1) = iMod(21.2964 + dblF1(1) + dblF2(1) + dblF3(1), 360)
    
    dblKRA1(1) = 0.1734 - (0.000393 * dblT(1))
    dblKRA2(1) = (dblKRA1(1) * Sin(dblM(1) * PI / 180))
    dblKRA3(1) = -0.4068 * Sin(dblMA(1) * PI / 180)
    dblKRA4(1) = 0.0021 * Sin(2 * dblM(1) * PI / 180)
    dblKRA5(1) = 0.0161 * Sin(2 * dblMA(1) * PI / 180)
    dblKRA6(1) = -0.0004 * Sin(3 * dblMA(1) * PI / 180)
    dblKORA(1) = (dblKRA2(1) + dblKRA3(1) + dblKRA4(1) + dblKRA5(1) + dblKRA6(1))
    
    dblKRB1(1) = -0.0051 * Sin((dblM(1) + dblMA(1)) * PI / 180)
    dblKRB2(1) = -0.0074 * Sin((dblM(1) - dblMA(1)) * PI / 180)
    dblKRB3(1) = 0.0004 * Sin((2 * dblF(1) + dblM(1)) * PI / 180)
    dblKRB4(1) = -0.0004 * Sin((2 * dblF(1) - dblM(1)) * PI / 180)
    dblKRB5(1) = 0.0104 * Sin(2 * dblF(1) * PI / 180)
    dblKORB(1) = (dblKRB1(1) + dblKRB2(1) + dblKRB3(1) + dblKRB4(1) + dblKRB5(1))
    dblKORB1(1) = -0.0051 * Sin((dblM(1) + dblMA(1)) * PI / 180) + _
                  -0.0074 * Sin((dblM(1) - dblMA(1)) * PI / 180) + _
                  0.0004 * Sin((2 * dblF(1) + dblM(1)) * PI / 180) + _
                  -0.0004 * Sin((2 * dblF(1) - dblM(1)) * PI / 180) + _
                  0.0104 * Sin(2 * dblF(1) * PI / 180)
    
    dblKC1(1) = -0.0006 * Sin((2 * dblF(1) + dblMA(1)) * PI / 180)
    dblKC2(1) = 0.001 * Sin((2 * dblF(1) - dblMA(1)) * PI / 180)
    dblKC3(1) = 0.0005 * Sin((dblM(1) + 2 * dblMA(1)) * PI / 180)
    dblKORC(1) = (dblKC1(1) + dblKC2(1) + dblKC3(1))
    dblKORC1(1) = -0.0006 * Sin((2 * dblF(1) + dblMA(1)) * PI / 180) + _
                  0.001 * Sin((2 * dblF(1) - dblMA(1)) * PI / 180) + _
                  0.0005 * Sin((dblM(1) + 2 * dblMA(1)) * PI / 180)
    
    dblKoreksi(1) = (dblKORA(1) + dblKORB(1) + dblKORC(1))
    
    dblJdA1(1) = 29.53058868 * dblKN(1)
    dblJdA2(1) = 0.0001178 * dblT(1) * dblT(1) * dblT(1)
    dblJdA3(1) = -0.000000155 * dblT(1) * dblT(1) * dblT(1)
    
    dblJdB1(1) = 132.87 * dblT(1)
    dblJdB2(1) = 0.009173 * dblT(1) * dblT(1)
    dblJdB3(1) = 166.56 + dblJdB1(1) - dblJdB2(1)
    
    dblJdC1(1) = 0.00033 * Sin(dblJdB3(1) * PI / 180)
    dblJdC2(1) = (dblJdA1(1) + dblJdA2(1) + dblJdA3(1) + dblJdC1(1))
    dblJdC3(1) = 2415020.75933 + dblJdC2(1)
    dblJD(1) = (dblJdC3(1) + 0.5 + dblKoreksi(1))
    
    dblZJd(1) = Trunc(dblJD(1))
    dblEFJd(1) = (dblJD(1) - dblZJd(1))
    dblAPJd(1) = Trunc((dblZJd(1) - 1867216.25) / 36524.25)
    dblAJd(1) = IIf(dblZJd(1) < 2299161, dblZJd(1), _
    dblZJd(1) + 1 + dblAPJd(1) - Trunc(dblAPJd(1) / 4))
    
    dblBJd(1) = (dblAJd(1) + 1524)
    dblCJd(1) = Trunc((dblBJd(1) - 122.1) / 365.25)
    dblDJd(1) = Trunc(365.25 * dblCJd(1))
    dblEJd(1) = Trunc((dblBJd(1) - dblDJd(1)) / 30.6001)
    
    dblTgl1(1) = (dblBJd(1) - dblDJd(1) - Trunc(30.6001 * dblEJd(1)) + dblEFJd(1))
    dblTgl2(1) = Trunc(dblTgl1(1))
    dblTgl3(1) = (dblTgl1(1) - dblTgl2(1))
    dblTgl4(1) = (dblTgl3(1) * 24)
    dblTgl5(1) = (dblTgl4(1) + 7)
    dblTglM(1) = IIf(dblTgl5(1) <= 24, dblTgl2(1), dblTgl2(1) + 1)
    
    dblKT(1) = (dblK4(1) - 100) / 100
    dblET1(1) = 123.5 * dblKT(1)
    dblET2(1) = 32.5 * dblKT(1) * dblKT(1)
    dblKET(1) = (102.3 + dblET1(1) + dblET2(1)) / 3600
    
    dblJDH(1) = IIf(dblTgl5(1) <= 24, (dblZJd(1) + 2), dblZJd(1) + 3)
    
    dblHasilBulan(1) = IIf(dblEJd(1) < 13.5, dblEJd(1) - 1, dblEJd(1) - 13)
    dblHasilTahun(1) = IIf(dblHasilBulan(1) < 2.5, _
    Trunc(dblCJd(1) - 4715), Trunc(dblCJd(1) - 4716))
    
    dblHasilHari(1) = (dblJDH(1) - Trunc(dblJDH(1) / 7) * 7)
    dblHasilPasaran(1) = (dblJDH(1) - Trunc(dblJDH(1) / 5) * 5)
    dblHasilJam(1) = IIf(dblTgl5(1) > 24, (dblTgl5(1) - 24), dblTgl5(1))
    
    
    'Tabel 2
    datHasil(1) = DateSerial(dblHasilTahun(1), dblHasilBulan(1), dblTglM(1))
    datFull(2) = IIf(datHasil(1) > datFull(1), datHasil(1) + 29, datHasil(1) + (29 * 2))
    '
    intIJST(2) = 1
    intTanggal(2) = Day(datFull(2))
    intBulan(2) = Month(datFull(2))
    intTahun(2) = Year(datFull(2))
    
    intTa1(2) = IIf((intTahun(2) Mod 4) = 0, 1, 0)
    intTa2(2) = IIf((intTahun(2) Mod 100) = 0, 1, 0)
    intTa3(2) = intTa1(2) + intTa2(2)
    
    dblKB(2) = IIf(intTa3(2) > 0, 1, 2)
    
    '===========================================================================
    
    dblK1(2) = Trunc((275 * intBulan(2)) / 9)
    dblK2(2) = Trunc((intBulan(2) + 9) / 12) * dblKB(2)
    dblK3(2) = (dblK1(2) - dblK2(2) + intTanggal(2) - 30)
    dblK4(2) = (dblK3(2) / 365.25) + (intTahun(2) - 1900)
    dblK5(2) = (dblK4(2) * 12.3685)
    dblK6(2) = (dblK5(2) - Trunc(dblK5(2)))
    dblK7(2) = IIf(dblK6(2) > 0.5, Trunc(dblK5(2) + 1), Trunc(dblK5(2) + 0))
    
    dblKN(2) = IIf(intIJST(2) = 1, (dblK7(2) - 0), (dblK7(2) - 0.5))
    dblT(2) = (dblKN(2) / 1236.85)
    
    dblM1(2) = 29.10535608 * dblKN(2)
    dblM2(2) = -0.000033 * dblT(2) * dblT(2)
    dblM3(2) = -0.00000347 * dblT(2) * dblT(2) * dblT(2)
    dblM(2) = iMod(359.2242 + dblM1(2) + dblM2(2) + dblM3(2), 360)
    
    dblMA1(2) = 385.81691806 * dblKN(2)
    dblMA2(2) = 0.0107306 * dblT(2) * dblT(2)
    dblMA3(2) = 0.00001236 * dblT(2) * dblT(2) * dblT(2)
    dblMA(2) = iMod(306.0253 + dblMA1(2) + dblMA2(2) + dblMA3(2), 360)
    
    dblF1(2) = 390.67050646 * dblKN(2)
    dblF2(2) = -0.0016528 * dblT(2) * dblT(2)
    dblF3(2) = -0.00000239 * dblT(2) * dblT(2) * dblT(2)
    dblF(2) = iMod(21.2964 + dblF1(2) + dblF2(2) + dblF3(2), 360)
    
    dblKRA1(2) = 0.1734 - (0.000393 * dblT(2))
    dblKRA2(2) = (dblKRA1(2) * Sin(dblM(2) * PI / 180))
    dblKRA3(2) = -0.4068 * Sin(dblMA(2) * PI / 180)
    dblKRA4(2) = 0.0021 * Sin(2 * dblM(2) * PI / 180)
    dblKRA5(2) = 0.0161 * Sin(2 * dblMA(2) * PI / 180)
    dblKRA6(2) = -0.0004 * Sin(3 * dblMA(2) * PI / 180)
    dblKORA(2) = (dblKRA2(2) + dblKRA3(2) + dblKRA4(2) + dblKRA5(2) + dblKRA6(2))
    
    dblKRB1(2) = -0.0051 * Sin((dblM(2) + dblMA(2)) * PI / 180)
    dblKRB2(2) = -0.0074 * Sin((dblM(2) - dblMA(2)) * PI / 180)
    dblKRB3(2) = 0.0004 * Sin((2 * dblF(2) + dblM(2)) * PI / 180)
    dblKRB4(2) = -0.0004 * Sin((2 * dblF(2) - dblM(2)) * PI / 180)
    dblKRB5(2) = 0.0104 * Sin(2 * dblF(2) * PI / 180)
    dblKORB(2) = (dblKRB1(2) + dblKRB2(2) + dblKRB3(2) + dblKRB4(2) + dblKRB5(2))
    dblKORB1(2) = -0.0051 * Sin((dblM(2) + dblMA(2)) * PI / 180) + _
                  -0.0074 * Sin((dblM(2) - dblMA(2)) * PI / 180) + _
                  0.0004 * Sin((2 * dblF(2) + dblM(2)) * PI / 180) + _
                  -0.0004 * Sin((2 * dblF(2) - dblM(2)) * PI / 180) + _
                  0.0104 * Sin(2 * dblF(2) * PI / 180)
    
    dblKC1(2) = -0.0006 * Sin((2 * dblF(2) + dblMA(2)) * PI / 180)
    dblKC2(2) = 0.001 * Sin((2 * dblF(2) - dblMA(2)) * PI / 180)
    dblKC3(2) = 0.0005 * Sin((dblM(2) + 2 * dblMA(2)) * PI / 180)
    dblKORC(2) = (dblKC1(2) + dblKC2(2) + dblKC3(2))
    dblKORC1(2) = -0.0006 * Sin((2 * dblF(2) + dblMA(2)) * PI / 180) + _
                  0.001 * Sin((2 * dblF(2) - dblMA(2)) * PI / 180) + _
                  0.0005 * Sin((dblM(2) + 2 * dblMA(2)) * PI / 180)
    
    dblKoreksi(2) = (dblKORA(2) + dblKORB(2) + dblKORC(2))
    
    dblJdA1(2) = 29.53058868 * dblKN(2)
    dblJdA2(2) = 0.0001178 * dblT(2) * dblT(2) * dblT(2)
    dblJdA3(2) = -0.000000155 * dblT(2) * dblT(2) * dblT(2)
    
    dblJdB1(2) = 132.87 * dblT(2)
    dblJdB2(2) = 0.009173 * dblT(2) * dblT(2)
    dblJdB3(2) = 166.56 + dblJdB1(2) - dblJdB2(2)
    
    dblJdC1(2) = 0.00033 * Sin(dblJdB3(2) * PI / 180)
    dblJdC2(2) = (dblJdA1(2) + dblJdA2(2) + dblJdA3(2) + dblJdC1(2))
    dblJdC3(2) = 2415020.75933 + dblJdC2(2)
    dblJD(2) = (dblJdC3(2) + 0.5 + dblKoreksi(2))
    
    dblZJd(2) = Trunc(dblJD(2))
    dblEFJd(2) = (dblJD(2) - dblZJd(2))
    dblAPJd(2) = Trunc((dblZJd(2) - 1867216.25) / 36524.25)
    dblAJd(2) = IIf(dblZJd(2) < 2299161, dblZJd(2), _
    dblZJd(2) + 1 + dblAPJd(2) - Trunc(dblAPJd(2) / 4))
    
    dblBJd(2) = (dblAJd(2) + 1524)
    dblCJd(2) = Trunc((dblBJd(2) - 122.1) / 365.25)
    dblDJd(2) = Trunc(365.25 * dblCJd(2))
    dblEJd(2) = Trunc((dblBJd(2) - dblDJd(2)) / 30.6001)
    
    dblTgl1(2) = (dblBJd(2) - dblDJd(2) - Trunc(30.6001 * dblEJd(2)) + dblEFJd(2))
    dblTgl2(2) = Trunc(dblTgl1(2))
    dblTgl3(2) = (dblTgl1(2) - dblTgl2(2))
    dblTgl4(2) = (dblTgl3(2) * 24)
    dblTgl5(2) = (dblTgl4(2) + 7)
    dblTglM(2) = IIf(dblTgl5(2) <= 24, dblTgl2(2), dblTgl2(2) + 1)
    
    dblKT(2) = (dblK4(2) - 100) / 100
    dblET1(2) = 123.5 * dblKT(2)
    dblET2(2) = 32.5 * dblKT(2) * dblKT(2)
    dblKET(2) = (102.3 + dblET1(2) + dblET2(2)) / 3600
    
    dblJDH(2) = IIf(dblTgl5(2) <= 24, (dblZJd(2) + 2), dblZJd(2) + 3)
    
    dblHasilBulan(2) = IIf(dblEJd(2) < 13.5, dblEJd(2) - 1, dblEJd(2) - 13)
    dblHasilTahun(2) = IIf(dblHasilBulan(2) < 2.5, _
    Trunc(dblCJd(2) - 4715), Trunc(dblCJd(2) - 4716))
    
    dblHasilHari(2) = (dblJDH(2) - Trunc(dblJDH(2) / 7) * 7)
    dblHasilPasaran(2) = (dblJDH(2) - Trunc(dblJDH(2) / 5) * 5)
    dblHasilJam(2) = IIf(dblTgl5(2) > 24, (dblTgl5(2) - 24), dblTgl5(2))
    
    datHasil(2) = DateSerial(dblHasilTahun(2), dblHasilBulan(2), dblTglM(2))
    
    Imlek = datHasil(2)
    
    Dim strShio(0 To 11) As String
    Dim intShio As Integer
    
    strShio(0) = "Ayam"
    strShio(1) = "Anjing"
    strShio(2) = "Babi"
    strShio(3) = "Tikus"
    strShio(4) = "Kerbau"
    strShio(5) = "Harimau"
    strShio(6) = "Kelinci"
    strShio(7) = "Naga"
    strShio(8) = "Ular"
    strShio(9) = "Kuda"
    strShio(10) = "Kambing"
    strShio(11) = "Monyet"
    
    intShio = (iTahun + 551) Mod 12
    Shio = strShio(intShio)
End Sub

- basNasional

Option Explicit

Public Proklamasi As Date

Sub Nasional(intTahun As Integer)
    Proklamasi = DateSerial(intTahun, 8, 17)
End Sub

Bagaimana cara pengujiannya? Gampang, pada Form1, tambahkan sebuah CommandButton, lalu ketik kode di bawah ini:

Option Explicit

Private Sub Command1_Click()
    Dim intYear As Integer
    intYear = Year(Date)

    Call Kristen(intYear)
    Call Hindu(intYear)
    Call Buddha(intYear)
    Call China(intYear)
    Call Islam(intYear)

    Dim strPesan As String

    strPesan = "Tahun: " & intYear & vbCrLf
    strPesan = strPesan & String(25, "=") & vbCrLf & vbCrLf
               
    strPesan = strPesan & "Maulid Nabi Muhammad: " & _
               Format(MaulidNabi, "d MMM yyyy") & vbCrLf
    strPesan = strPesan & "Isra' Mi'raj Nabi Muhammad: " & _
               Format(IsraMiraj, "d MMM yyyy") & vbCrLf
    strPesan = strPesan & "Idul Fitri: " & _
               Format(IdulFitri, "d MMM yyyy") & vbCrLf
    strPesan = strPesan & "Idul Adha: " & _
               Format(IdulAdha, "d MMM yyyy") & vbCrLf
    strPesan = strPesan & "Tahun Baru Hijriyah: " & _
               Format(TahunBaruHijri, "d MMM yyyy") & vbCrLf & vbCrLf
               
    strPesan = strPesan & "Wafat Isa Al Masih: " & _
               Format(WafatIsa, "d MMM yyyy") & vbCrLf
    strPesan = strPesan & "Kenaikan Isa Al Masih: " & _
               Format(KenaikanIsa, "d MMM yyyy") & vbCrLf
    strPesan = strPesan & "Natal: " & _
               Format(Natal, "d MMM yyyy") & vbCrLf
    strPesan = strPesan & "Tahun Baru: " & _
               Format(TahunBaru, "d MMM yyyy") & vbCrLf & vbCrLf
               
    strPesan = strPesan & "Nyepi: " & _
               Format(Nyepi, "d MMM yyyy") & vbCrLf & vbCrLf
               
    strPesan = strPesan & "Waisak: " & _
               Format(Waisak, "d MMM yyyy") & vbCrLf & vbCrLf
               
    strPesan = strPesan & "Imlek: " & _
               Format(Imlek, "d MMM yyyy") & _
               " (" & Shio & ")" & vbCrLf & vbCrLf

    MsgBox strPesan, vbInformation, "Kalender"
End Sub

Hasil

Nah, selanjutnya tinggal mendayagunakan kemampuan Anda untuk menjadikan aplikasi lain sesuai kebutuhan Anda.

Perhatian:

Kode sumber di atas hanya boleh digunakan untuk keperluan non profit (untuk keperluan ini, harus menyertakan alamat blog http://www.pujanggavb.wordpress.com sebagai sumber referensi). Untuk keperluan komersial, harus menghubungi saya melalui email ke: pujanggabageur@yahoo.com.

Disimpan dalam Aplikasi, Artikel Ringan, Visual Basic 6.0 Dikaitkatakan dengan buddha, china, cuti, cuti bersama, Hijriyah, hindu, imlek, Islam, kalender, kristen, Masehi, nyepi, vb classic, VB6, Visual Basic, waisak

Kalender Indonesia (Beserta Hari Libur dan Cuti Bersama)

31 Januari 2012 2 Komentar

Bagi karyawan swasta seperti saya, kalender memang sangat diperlukan keberadaannya. Ya, apalagi selain melihat jadwal hari libur . ‘Kehadiran’ kalender baru memang sangat ditunggu-tunggu untuk menentukan rencana liburan keluarga. Nah setelah berkeliling menggunakan Google untuk mencari kalender yang disertai jadwal hari libur, akhirnya saya menemukan alamat ini: http://moeidzahid.site90.net/kalender/kalenderr1.htm

Baca tulisan ini lebih lanjut

Disimpan dalam Aplikasi, Visual Basic 6.0

ActiveX Calender

19 November 2008 1 Komentar

Ini contoh ActiveX semacam MonthView atau DTPicker kepunyaan VB, berikut ini tampilan ActiveX ketika dijalankan:

Silakan unduh di:
OCX Calender

Disimpan dalam ActiveX Control

Fungsi-Fungsi Matematika

17 November 2008 Tinggalkan Komentar

Beikut ini contoh-contoh fungsi matematika, seperti: penjumlahan, perkalian, rata-rata, dsb. Deklarasikan fungsi-fungsi ini di sebuah class.

Option Explicit

Private i As Integer
Private mValue As Double

'Fungsi Penjumlahan
Function Sum(ParamArray Angka()) As Double
    mValue = 0
    For i = 0 To UBound(Angka)
        mValue = mValue + Angka(i)
    Next
    Sum = mValue
End Function

'Fungsi Rata-rata
Function Average(ParamArray Angka()) As Double
    mValue = 0
    For i = 0 To UBound(Angka)
        mValue = mValue + Angka(i)
    Next
    Average = mValue / i
End Function

'Funsi Perkalian
Function Multiply(ParamArray Angka()) As Double
    mValue = 1
    For i = 0 To UBound(Angka)
        mValue = mValue * Angka(i)
    Next
    Multiply = mValue
End Function

'Konversi Binear ke Desimal
Function BinearToDecimal(Nilai) As Long
    Dim intLen As Integer

    mValue = 0
    intLen = Len(CStr(Nilai))
    For i = 1 To intLen
        mValue = mValue + CLng(Mid(Nilai, i, 1)) * _
                (2 ^ (intLen - i))
    Next
    '
    BinearToDecimal = mValue
End Function

'Konversi Desimal ke Basis
Function Basis(IntAngka%, intBasis%) As String
    Dim intNilai&amp;
    Dim intLen%
    Dim strHasil$, strHexa$, strEnd$, strSub$
    Do
        intNilai = IntAngka Mod intBasis
        IntAngka = IntAngka \ intBasis
        Select Case intNilai
            Case 10: strHexa = "A"
            Case 11: strHexa = "B"
            Case 12: strHexa = "C"
            Case 13: strHexa = "D"
            Case 14: strHexa = "E"
            Case 15: strHexa = "F"
            Case Else:
                strHexa = CStr(intNilai)
        End Select
         strHasil = strHasil + strHexa
    Loop Until IntAngka &lt; intBasis

    intLen = Len(strHasil)
    strEnd = CStr(IntAngka)

    For i = intLen To 1 Step -1
        strSub = strSub + Mid(strHasil, i, 1)
    Next

    If (Mid(strEnd + strSub, 1, 1)) = "0" Then
        Basis = Mid(strEnd + strSub, _
          2, Len(strEnd + strSub) - 1)
    Else
        Basis = strEnd + strSub
    End If

End Function

'Konversi Desimal ke Romawi
Function Roman(IntAngka As Integer) As String
    Dim IntSeribu%, IntLimaRatus%
    Dim IntSeratus%, IntLimaPuluh%
    Dim IntSepuluh%, IntLima%, IntSatu%
    Dim StrSeribu$, StrLimaRatus$
    Dim StrSeratus$, StrLimaPuluh$
    Dim StrSepuluh$, StrLima$, StrSatu$
    Dim StrRomawi$

    IntSatu = IntAngka
    IntSeribu = IntAngka \ 1000
    IntSatu = IntAngka Mod 1000
    IntLimaRatus = IntSatu \ 500
    IntSatu = IntAngka Mod 500
    IntSeratus = IntSatu \ 100
    IntSatu = IntAngka Mod 100
    IntLimaPuluh = IntSatu \ 50
    IntSatu = IntAngka Mod 50
    IntSepuluh = IntSatu \ 10
    IntSatu = IntAngka Mod 10
    IntLima = IntSatu \ 5
    IntSatu = IntAngka Mod 5

    For i = 0 To IntSeribu - 1
        StrSeribu = StrSeribu + "M"
    Next

    If IntSeratus &lt;&gt; 4 Then
        For i = 0 To IntLimaRatus - 1
            StrLimaRatus = StrLimaRatus + "D"
        Next
    End If

    For i = 0 To IntSeratus - 1
        StrSeratus = StrSeratus + "C"
    Next

        If IntSeratus = 4 Then
            If IntLimaRatus = 1 Then
                StrSeratus = StrRomawi + "CM"
            Else
                StrSeratus = StrRomawi + "CD"
            End If
        End If

    If IntSepuluh &lt;&gt; 4 Then
        For i = 0 To IntLimaPuluh - 1
            StrLimaPuluh = StrLimaPuluh + "L"
        Next
    End If

    For i = 0 To IntSepuluh - 1
        StrSepuluh = StrSepuluh + "X"
    Next

        If IntSepuluh = 4 Then
            If IntLimaPuluh = 1 Then
                StrSepuluh = StrRomawi + "XC"
            Else
                StrSepuluh = StrRomawi + "XL"
            End If
        End If

        If IntSatu &lt;&gt; 4 Then
            For i = 0 To IntLima - 1
                StrLima = StrLima + "V"
            Next
        End If

        For i = 0 To IntSatu - 1
            StrSatu = StrSatu + "I"
        Next

        If IntSatu = 4 Then
            If IntLima = 1 Then
                StrSatu = StrRomawi + "IX"
            Else
                StrSatu = StrRomawi + "IV"
            End If
        End If

    StrRomawi = StrSeribu + StrLimaRatus _
                + StrSeratus + StrLimaPuluh _
                + StrSepuluh + StrLima + StrSatu
    Roman = StrRomawi
End Function

'Fungsi mencari nilai maksimum dengan
'menggunakan parameter input berupa array

Function NilaiMax1(ParamArray Nilai()) As Double
    Dim i As Long
    Dim nMax As Double
    Dim nTemp As Double

    For i = LBound(Nilai) To UBound(Nilai)
        nMax = Nilai(i)
        If nTemp &gt; nMax Then
            nMax = nTemp
        End If
        nTemp = nMax
    Next
    NilaiMax1 = nMax
End Function

'Fungsi mencari nilai maksimum dengan
'menggunakan parameter input berupa daftar deret

Function NilaiMax2(DeretAngka$) As Double
    Dim i As Long
    Dim nMax As Double
    Dim nTemp As Double

    Dim Pisah() As String
    Pisah = Split(DeretAngka$, ";")

    For i = LBound(Pisah) To UBound(Pisah)
        nMax = Val(Pisah(i))
        If nTemp &gt; nMax Then
            nMax = nTemp
        End If
        nTemp = nMax
    Next
    NilaiMax2 = nMax
End Function

'Fungsi mencari nilai minimum dengan
'menggunakan parameter input berupa array

Function NilaiMin1(ParamArray Nilai()) As Double
    Dim i As Long
    Dim nMin As Double
    Dim nTemp As Double

    nTemp = 1

    For i = LBound(Nilai) To UBound(Nilai)
        nMin = Nilai(i)
        If nTemp &lt; nMin Then
            nMin = nTemp
        End If
        nTemp = nMin
    Next
    NilaiMin1 = nMin
End Function

'Fungsi mencari nilai minimum dengan
'menggunakan parameter input berupa daftar deret

Function NilaiMin2(DeretAngka$) As Double
    Dim i As Long
    Dim nMin As Double
    Dim nTemp As Double

    Dim Pisah() As String
    Pisah = Split(DeretAngka$, ";")

    nTemp = 1

    For i = LBound(Pisah) To UBound(Pisah)
        nMin = Val(Pisah(i))
        If nTemp &lt; nMin Then
            nMin = nTemp
        End If
        nTemp = nMin
    Next
    NilaiMin2 = nMin
End Function

Private Sub Class_Initialize()
    mValue = 0
End Sub

Namai class degan “cMath”. Untuk bahan pengujian, ketik kode di bawah ini

Dim myMath As New cMath

Private Sub Form_Load()
    Set myMath = New cMath

    MsgBox myMath.Average(7, 8, 3, 2, 7, 5, 8, 4, 2, 3)
    MsgBox myMath.Sum(7, 8, 3, 2, 7, 5, 8, 4, 2, 3)
    MsgBox myMath.Multiply(5, 8, 4, 2, 3)
    MsgBox myMath.BinearToDecimal("1001010011100")
    MsgBox myMath.Roman(2008)

End Sub

Disimpan dalam Tips dan Trik

Konversi Basis Data

17 November 2008 Tinggalkan Komentar

Ini contoh cara mengkonversi basis bilangan.

Kode pada module:

Option Explicit
'
Function DesimalKeBinear$(Nilai&amp;)
    Dim Nilai2 As Long
    Dim Hasil As String
    Dim LHasil As Integer
    Dim i As Integer
    Do Until Nilai = 0
        Nilai2 = Nilai Mod 2
        Nilai = Nilai \ 2
        Hasil = Hasil &amp; CStr(Nilai2)
    Loop
    LHasil = Len(Hasil)
    For i = 0 To LHasil - 1
        DesimalKeBinear$ = DesimalKeBinear$ &amp; _
        Mid(Hasil, LHasil - i, 1)
    Next
End Function
'
Function DesimalKeHexa$(Nilai&amp;)
    Dim Nilai2 As Long
    Dim NilaiHexa As String
    Dim Hasil As String
    Dim LHasil As Integer
    Dim i As Integer
    Do Until Nilai = 0
        Nilai2 = Nilai Mod 16
        Nilai = Nilai \ 16
        Select Case Nilai2
            Case 10: NilaiHexa = "A"
            Case 11: NilaiHexa = "B"
            Case 12: NilaiHexa = "C"
            Case 13: NilaiHexa = "D"
            Case 14: NilaiHexa = "E"
            Case 15: NilaiHexa = "F"
            Case Else: NilaiHexa = CStr(Nilai2)
        End Select
        Hasil = Hasil &amp; NilaiHexa
    Loop
    LHasil = Len(Hasil)
    For i = 0 To LHasil - 1
        DesimalKeHexa$ = DesimalKeHexa$ &amp; Mid(Hasil, LHasil - i, 1)
    Next
    DesimalKeHexa$ = "&amp;H" &amp; DesimalKeHexa$
End Function
'
Function BinearKeDesimal&amp;(Nilai$)
    Dim LNilai As Integer
    Dim i As Integer
    Dim j As Integer
    Dim Hasil As Long
    LNilai = Len(Nilai$)

    For i = 1 To LNilai
        Hasil = Hasil + CLng(Mid(Nilai, i, 1)) * _
                (2 ^ (LNilai - i))
        '1--&gt; 1 * 2 ^ 6
        '2--&gt; 1 * 2 ^ 5
        '3--&gt; 0 * 2 ^ 4
        '4--&gt; 0 * 2 ^ 3
        '5--&gt; 1 * 2 ^ 2
        '6--&gt; 0 * 2 ^ 1
        '7--&gt; 0 * 2 ^ 0
    Next
    '
    BinearKeDesimal&amp; = Hasil
End Function
'
Function HexaKeDesimal&amp;(Nilai$)
    Dim Nilai2 As String
    Dim NilaiDes As Integer
    Dim Hasil As Long
    Dim LNilai As Integer
    Dim i As Integer
    LNilai = Len(Nilai)
    For i = 3 To LNilai
        Nilai2 = Mid(Nilai, i, 1)
        Select Case UCase(Nilai2)
            Case "A": NilaiDes = 10
            Case "B": NilaiDes = 11
            Case "C": NilaiDes = 12
            Case "D": NilaiDes = 13
            Case "E": NilaiDes = 14
            Case "F": NilaiDes = 15
            Case Else: NilaiDes = CInt(Nilai2)
        End Select
        Hasil = Hasil + (NilaiDes * (16 ^ (LNilai - i)))
    Next
    HexaKeDesimal&amp; = Hasil
End Function

Kode di form:

Option Explicit

Private Sub cmdBinearKeDes_Click()
    Me.txtHasil.Text = BinearKeDesimal(Me.txtNilai.Text)
End Sub
'
Private Sub cmdDesKeBinear_Click()
    Me.txtHasil.Text = DesimalKeBinear(Me.txtNilai.Text)
End Sub
'
Private Sub cmdDesKeHexa_Click()
    Me.txtHasil.Text = DesimalKeHexa(Me.txtNilai.Text)
End Sub
'
Private Sub cmdHexaKeDes_Click()
    Me.txtHasil.Text = HexaKeDesimal(Me.txtNilai.Text)
End Sub
'
Private Sub cmdBinearKeHexa_Click()
    Dim nDesimal As Long
    nDesimal = BinearKeDesimal(Me.txtNilai.Text)
    Me.txtHasil.Text = DesimalKeHexa(nDesimal)
End Sub
'
Private Sub cmdHexaKeBinear_Click()
    Dim nDesimal As Long
    nDesimal = HexaKeDesimal(Me.txtNilai.Text)
    Me.txtHasil.Text = DesimalKeBinear(nDesimal)
End Sub

Form nya seperti ini:

VERSION 5.00
Begin VB.Form Form1
   BackColor       =   &amp;H00C0C0C0&amp;
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "INOCHI - KONVERTER"
   ClientHeight    =   3045
   ClientLeft      =   45
   ClientTop       =   435
   ClientWidth     =   6960
   BeginProperty Font
      Name            =   "Times New Roman"
      Size            =   12
      Charset         =   0
      Weight          =   700
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "Form1.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3045
   ScaleWidth      =   6960
   StartUpPosition =   2  'CenterScreen
   Begin VB.CommandButton cmdHexaKeBinear
      Caption         =   "&amp;HEXA KE BINEAR"
      Height          =   495
      Left            =   3990
      TabIndex        =   9
      Top             =   2460
      Width           =   2865
   End
   Begin VB.CommandButton cmdBinearKeHexa
      Caption         =   "B&amp;INEAR KE HEXA"
      Height          =   495
      Left            =   3990
      TabIndex        =   8
      Top             =   1980
      Width           =   2865
   End
   Begin VB.CommandButton cmdHexaKeDes
      Caption         =   "H&amp;EXA KE DESIMAL"
      Height          =   495
      Left            =   3990
      TabIndex        =   7
      Top             =   1500
      Width           =   2865
   End
   Begin VB.CommandButton cmdBinearKeDes
      Caption         =   "&amp;BINEAR KE DESIMAL"
      Height          =   495
      Left            =   3990
      TabIndex        =   6
      Top             =   1020
      Width           =   2865
   End
   Begin VB.CommandButton cmdDesKeHexa
      Caption         =   "D&amp;ESIMAL KE HEXA"
      Height          =   495
      Left            =   3990
      TabIndex        =   5
      Top             =   540
      Width           =   2865
   End
   Begin VB.CommandButton cmdDesKeBinear
      Caption         =   "&amp;DESIMAL KE BINEAR"
      Height          =   495
      Left            =   3990
      TabIndex        =   4
      Top             =   60
      Width           =   2865
   End
   Begin VB.TextBox txtHasil
      Alignment       =   1  'Right Justify
      BorderStyle     =   0  'None
      Height          =   285
      Left            =   180
      Locked          =   -1  'True
      TabIndex        =   3
      Top             =   1800
      Width           =   3555
   End
   Begin VB.TextBox txtNilai
      Alignment       =   1  'Right Justify
      BorderStyle     =   0  'None
      Height          =   285
      Left            =   180
      TabIndex        =   1
      Text            =   "240982"
      Top             =   990
      Width           =   3555
   End
   Begin VB.Label Label1
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "NILAI HASIL"
      Height          =   285
      Index           =   1
      Left            =   180
      TabIndex        =   2
      Top             =   1470
      Width           =   1455
   End
   Begin VB.Label Label1
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "NILAI &amp;MASUKAN"
      Height          =   285
      Index           =   0
      Left            =   180
      TabIndex        =   0
      Top             =   660
      Width           =   1965
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Tempelkan baris kode di atas pada Notepad, Save-As jadi “Form1.frm” (Save As Type = All Files)

Disimpan dalam Tips dan Trik

Fungsi Receh/Pecahan Uang

17 November 2008 1 Komentar

Terinspirasikan dari sebuah pertanyaan di forum VB-Bego, berikut petikan pertanyaan (setelah diedit sebagian, red):

Salam kenal..

...
lg bikin function receh nih..
mirip2 function terbilang gitu logikanya..serupa tapi tak sama..
hasil yang pengen ditampilin :
Untuk : 139.716
jumlah 100.000 yang dibutuhkan 1
jumlah 50.000 yang dibutuhkan 0
jumlah 20.000 yang dibutuhkan 1
jumlah 10.000 yang dibutuhkan 1
jumlah 5000 yang dibutuhkan 1
jumlah 1000 yang dibutuhkan 4
jumlah 500 yang dibutuhkan 1
jumlah 100 yang dibutuhkan 2

Maka, dibuatlah fungsi sesuai keinginan penanya:

Fungsi:

Function Pecahan(Angka As Long, Index As Integer) As Integer
    Dim Angka2 As Long
    Dim NominalUang(1 To 10) As Integer

    Angka2 = Angka

        If Angka2 >= 100000 Then
            NominalUang(1) = Angka2 \ 100000
            Angka2 = Angka2 Mod 100000
        End If

        If Angka2 >= 50000 Then
            NominalUang(2) = Angka2 \ 50000
            Angka2 = Angka2 Mod 50000
        End If

        If Angka2 >= 20000 Then
            NominalUang(3) = Angka2 \ 20000
            Angka2 = Angka2 Mod 20000
        End If

        If Angka2 >= 10000 Then
            NominalUang(4) = Angka2 \ 10000
            Angka2 = Angka Mod 10000
        End If

        If Angka2 >= 5000 Then
            NominalUang(5) = Angka2 \ 5000
            Angka2 = Angka2 Mod 5000
        End If

        If Angka2 >= 1000 Then
            NominalUang(6) = Angka2 \ 1000
            Angka2 = Angka2 Mod 1000
        End If

        If Angka2 >= 500 Then
            NominalUang(7) = Angka2 \ 500
            Angka2 = Angka2 Mod 500
        End If

        If Angka2 >= 200 Then
            NominalUang(8) = Angka2 \ 200
            Angka2 = Angka2 Mod 200
        End If

        If Angka2 >= 100 Then
            NominalUang(9) = Angka2 \ 100
            Angka2 = Angka2 Mod 100
        End If

        If Angka2 >= 50 Then
            NominalUang(10) = Angka2 \ 50
            Angka2 = Angka2 Mod 100
        End If
    Pecahan = NominalUang(Index)
End Function

Contoh pengujian:
Tambahkan sebuah TextBox pada form, namai dengan txtNominal. Tambahkan pula sebuah CommandButton, ketik kode di bawah ini:

Private Sub Command1_Click()

    Dim i As Integer

    MsgBox Pecahan(CLng(Me.txtNominal), 1) & " SeratusRibuan"
    MsgBox Pecahan(CLng(Me.txtNominal), 2) & " LimaPuluhRibuan"
    MsgBox Pecahan(CLng(Me.txtNominal), 3) & " DuaPuluhRibuan"
    MsgBox Pecahan(CLng(Me.txtNominal), 4) & " SepuluhRibuan"
    MsgBox Pecahan(CLng(Me.txtNominal), 5) & " LimaRibuan"
    MsgBox Pecahan(CLng(Me.txtNominal), 6) & " Seribuan"
    MsgBox Pecahan(CLng(Me.txtNominal), 7) & " LimaRatusan"
    MsgBox Pecahan(CLng(Me.txtNominal), 8) & " DuaRatusan"
    MsgBox Pecahan(CLng(Me.txtNominal), 9) & " Seratusan"
    MsgBox Pecahan(CLng(Me.txtNominal), 10) & " LimaPuluhan"
End Sub

Disimpan dalam Artikel Ringan

← Tulisan lebih awal

Mei 2013
S	S	R	K	J	S	M
« Mei
	1	2	3	4	5
6	7	8	9	10	11	12
13	14	15	16	17	18	19
20	21	22	23	24	25	26
27	28	29	30	31

Twitter

@aheryawan duh mang jln di kota jiga di gunung, komo deui jln di gng, cik ulah saukur "sampaikn ke pihak anu", direspon teu ku maranehna teh 3 days ago
Makin menantang nih! Gue baru lewat level 4 dari 8 level di fase 2.. bit.ly/XklhWM! #asahotakinovator2 1 month ago
Hints 42: judul lagunya Lilis Karlina :)) #asahotakinovator2 1 month ago
Hints level 42: Yoga #asahotakinovator2 1 month ago
Akhirnya berhasil lewat level 42 #AsahOtakInovator2 http://t.co/5x3kSEBSGu 1 month ago

Follow @pujanggabageur

	Fadhly on Menghitung Hari Libur Kea…
	Fadhly on Tentang Saya
	Siputih on Kalender Indonesia (Beserta Ha…
	calton on Kalender Indonesia (Beserta Ha…
	adit on PictureBox Transparant (sepert…

Ampiran Visual Basic 6

Motor matic injeksi irit harga murah – Yamaha Mio J

Menghitung Hari Libur Keagamaan

Kalender Indonesia (Beserta Hari Libur dan Cuti Bersama)

ActiveX Calender

Fungsi-Fungsi Matematika

Konversi Basis Data

Fungsi Receh/Pecahan Uang

WAZZUB

Tulisan Terkini

Kategori

Arsip

Kalender

Komentar Terakhir

Twitter

Follow “Ampiran Visual Basic 6”