Source Code Aplikasi Converter Angka Number ke Angka Romawi di VB6

Source Code Aplikasi Converter Angka Number ke Angka Romawi di VB6

Selamat datang kembali di TeknoTips.NET. TeknoTips.NET adalah media online Indonesia yang diluncurkan pada bulan Maret 2015. Kami berkomitmen menyajikan konten seputar teknologi yang berkualitas dan bermanfaat. Ulasan kami terdiri dari berbagai topik: pemrograman komputer & database, review produk, tutorial windows, linux, android, kumpulan source code & project program, referensi tugas akhir & skripsi, download ebook, game & software.

Pada kesempatan ini kita akan mengulas artikel yang berjudul : Source Code Aplikasi Converter Angka Number ke Angka Romawi di VB6.

Cara Membuat Aplikasi Converter Angka Number ke Angka Romawi dengan VB6 - Pada zaman dahulu kala orang romawi kuno menggunakan penomoran tersendiri yang sangat berbeda dengan sistem penomeran pada jaman seperti sekarang.Penomeran romawi hanya terdiri dari 7 nomor dengan simbol huruf tertentu di mana setiap huruf melambangkan / memiliki arti angka tertentu. Diantara 7 nomor itu adalah I V X L C D M.

Pada pertemuan kali ini Saya ingin berbagi trik bagaimana cara membuat program aplikasi converter angka dari angka Number menjadi angka Romawi atau sebaliknya dari angka Romawai ke angka Number.

Bagi Anda yang penasaran bagaimana cara membuatnya ikuti langkah-langkah berikut dibawah ini :


Program Aplikasi Converter Angka Number ke Angka Romawi

1. Buka Form VB6 Anda
2. Pada Form1 ubah Name Propertiesnya menjadi : frmRoman dan Caption-nya: "Decimal to 
    Roman / Roman to Decimal Converter"
3. Tambahkan 1 Frame didalam Form, ubah Captionnya menjadi "Select Conversion Type"
4. Tanamkan 2 optionButton kedalam Frame uban Name-nya masing-masing menjadi :
    optDecimalToRoman dan optRomanToDecimal
5. Tanamkan 1 Label dengan tulisan "Enter a number between 1 and 3999:", ubah Name-nya 
     menjadi : lblPrompt
6. Tanamkan 1 TextBox ubah Name-nya menjadi : txtInput, Text-nya kosongkan
7. Tanamkan 1 Label dengan Tulisan Roman Numeral Equivalent:, ubah Name-nya menjadi :
     lblOutputDesc
8. Tanamkan 1 Label lagi dengan Caption :" "(dibiarkan kosong), ubah BorderStyle :Fixed Single,
     Name-nya: lblOutput
9. Tanamkan 2 Commanbutton : Commanbutton1 ubah Name-nya menjadi : cmdConvert
    Caption-nya :"Convert" kemudian Commandbutto2 ubah Name-nya menjadi :cmdExit dan ganti     Caption-nya menjadi      : "Exit"
10. Desainlah form seperti Gambar dibawah ini:
Desain Converter Numeric to Roman

11. Setelah selesai desain form Sekarang buka jendela kode dan ketik kode dibawah ini :

Option Explicit

Private Sub Form_Load()
End Sub

Private Sub optDecimalToRoman_Click()

    lblPrompt.Caption = "Enter a number between 1 and 3999:"
    lblOutputDesc.Caption = "Roman Numeral Equivalent:"
    txtInput.Text = ""
    txtInput.MaxLength = 4
    lblOutput.Caption = ""
End Sub

Private Sub optRomanToDecimal_Click()

    lblPrompt.Caption = "Enter a Roman Numerals number between I and MMMCMXCIX:"
    lblOutputDesc.Caption = "Decimal Equivalent:"
    txtInput.Text = ""
    txtInput.MaxLength = 16
    lblOutput.Caption = ""
End Sub

Private Sub txtInput_GotFocus()

    With txtInput
        .SelStart = 0
        .SelLength = Len(.Text)
    End With
End Sub

Private Sub txtInput_KeyPress(KeyAscii As Integer)

    If KeyAscii < 32 Then Exit Sub
 
    If optDecimalToRoman.Value = True Then
        If InStr("0123456789", Chr$(KeyAscii)) = 0 Then
            KeyAscii = 0
        End If
    Else
        If Chr$(KeyAscii) >= "a" And Chr$(KeyAscii) <= "z" Then
            KeyAscii = KeyAscii - 32
        End If
        If InStr("MDCLXVI", Chr$(KeyAscii)) = 0 Then
            KeyAscii = 0
        End If
    End If
 
End Sub

Private Sub txtInput_Change()

    lblOutput.Caption = ""

End Sub

Private Sub cmdConvert_Click()

    Dim intLetterPos            As Integer
    Dim strRomanNumeralString   As String
    Dim strInvalidRomanInputMsg As String
 
    If optDecimalToRoman.Value = True Then
        If Val(txtInput.Text) < 1 _
        Or Val(txtInput.Text) > 3999 Then
            MsgBox "Number out of range. Please enter a number between 1 and 3999.", _
                   vbExclamation, _
                   "Number Out of Range"
            txtInput.SetFocus
            Exit Sub
        End If
     
        lblOutput.Caption = ConvertToRoman(txtInput.Text)
    Else
        strRomanNumeralString = txtInput.Text
     
        If Not ValidRomanInput(strRomanNumeralString, strInvalidRomanInputMsg) Then
            MsgBox strInvalidRomanInputMsg, _
                   vbExclamation, _
                   "Invalid Roman Numeral String"
            txtInput.SetFocus
            Exit Sub
        End If     
        lblOutput.Caption = ConvertToDecimal(txtInput.Text)
    End If 

End Sub

Private Sub cmdExit_Click()
    End
End Sub

Private Function ConvertToRoman(pstrDecimalNumber As String) As String

    Const strPOS_VAL    As String = "IXCM"
    Const strFIVE_VAL   As String = "VLD"
 
    Dim strRoman        As String
    Dim strCurrRomanPos As String
    Dim strLetter1      As String
    Dim strLetter2      As String
    Dim intCurrPos      As Integer
    Dim intDigit        As Integer
    Dim intDigitPos     As Integer
 
    intCurrPos = 1
    strRoman = ""
 
    For intDigitPos = Len(pstrDecimalNumber) To 1 Step -1
        intDigit = Val(Mid$(pstrDecimalNumber, intDigitPos, 1))
        strCurrRomanPos = Mid$(strPOS_VAL, intCurrPos, 1)
        Select Case intDigit
            Case 9
                strLetter1 = strCurrRomanPos
                strLetter2 = Mid$(strPOS_VAL, intCurrPos + 1, 1)
            Case Is > 4
                strLetter1 = Mid$(strFIVE_VAL, intCurrPos, 1)
                strLetter2 = String$(intDigit - 5, strCurrRomanPos)
            Case 4
                strLetter1 = strCurrRomanPos
                strLetter2 = Mid$(strFIVE_VAL, intCurrPos, 1)
            Case Else
                strLetter1 = String$(intDigit, strCurrRomanPos)
                strLetter2 = ""
        End Select
        strRoman = strLetter1 & strLetter2 & strRoman
        intCurrPos = intCurrPos + 1
    Next

    ConvertToRoman = strRoman

End Function

Private Function ConvertToDecimal(pstrRomanNumeral As String) As String

    Dim aintRomanValues()   As Integer
    Dim intInputLen         As Integer
    Dim intX                As Integer
    Dim intSum              As Integer
 
    intInputLen = Len(pstrRomanNumeral)
 
    If intInputLen = 0 Then
        ConvertToDecimal = 0
        Exit Function
    End If
 
    ReDim aintRomanValues(1 To intInputLen)
 
    For intX = 1 To intInputLen
        Select Case Mid$(pstrRomanNumeral, intX, 1)
            Case "M":   aintRomanValues(intX) = 1000
            Case "D":   aintRomanValues(intX) = 500
            Case "C":   aintRomanValues(intX) = 100
            Case "L":   aintRomanValues(intX) = 50
            Case "X":   aintRomanValues(intX) = 10
            Case "V":   aintRomanValues(intX) = 5
            Case "I":   aintRomanValues(intX) = 1
        End Select
    Next
 
    For intX = 1 To intInputLen
        If intX = intInputLen Then
            intSum = intSum + aintRomanValues(intX)
        Else
            If aintRomanValues(intX) >= aintRomanValues(intX + 1) Then
                intSum = intSum + aintRomanValues(intX)
            Else
                intSum = intSum - aintRomanValues(intX)
            End If
        End If
    Next
    ConvertToDecimal = CStr(intSum)

End Function

Private Function ValidRomanInput(ByVal pstrRN As String, ByRef pstrMsg As String) As Boolean    
    ValidRomanInput = False         ' Guilty until proven innocent!
     
    ' a 'D', 'L', or 'V' may only appear at most once in the string

    If GetSubstringCount(pstrRN, "D") > 1 _
    Or GetSubstringCount(pstrRN, "L") > 1 _
    Or GetSubstringCount(pstrRN, "V") > 1 Then
        pstrMsg = "'D', 'L', or 'V' may only appear at most once."
        Exit Function
    End If
 
    ' no more than 3 consecutive Ms, Cs, Xs or Is:

    If InStr(pstrRN, "MMMM") > 0 _
    Or InStr(pstrRN, "CCCC") > 0 _
    Or InStr(pstrRN, "XXXX") > 0 _
    Or InStr(pstrRN, "IIII") > 0 Then
        pstrMsg = "'M', 'C', 'X', or 'I' may appear no more than three times in a row."
        Exit Function
    End If
 
    ' Outright illegal sequences:

    If InStr(pstrRN, "IL") > 0 _
    Or InStr(pstrRN, "IC") > 0 _
    Or InStr(pstrRN, "ID") > 0 _
    Or InStr(pstrRN, "IM") > 0 _
    Or InStr(pstrRN, "XD") > 0 _
    Or InStr(pstrRN, "XM") > 0 _
    Or InStr(pstrRN, "VX") > 0 _
    Or InStr(pstrRN, "VL") > 0 _
    Or InStr(pstrRN, "VC") > 0 _
    Or InStr(pstrRN, "VD") > 0 _
    Or InStr(pstrRN, "VM") > 0 _
    Or InStr(pstrRN, "LC") > 0 _
    Or InStr(pstrRN, "LD") > 0 _
    Or InStr(pstrRN, "LM") > 0 _
    Or InStr(pstrRN, "DM") > 0 _
    Then
        pstrMsg = "The Roman Numeral string contains an illegal sequence of characters."
        Exit Function
    End If
 
    ' Other illegal sequences:

    ' Once a letter has been subtracted from, neither it nor its "5 counterpart" may appear
    ' again in the string - so neither X nor V can follow IX, neither C nor L may follow XC,
    ' and neither M nor D may follow CM.

    If AFollowsBInC("X", "IX", pstrRN) Then pstrMsg = "'X' cannot follow 'IX'.": Exit Function
    If AFollowsBInC("V", "IX", pstrRN) Then pstrMsg = "'V' cannot follow 'IX'.": Exit Function
    If AFollowsBInC("C", "XC", pstrRN) Then pstrMsg = "'C' cannot follow 'XC'.": Exit Function
    If AFollowsBInC("L", "XC", pstrRN) Then pstrMsg = "'L' cannot follow 'XC'.": Exit Function
    If AFollowsBInC("M", "CM", pstrRN) Then pstrMsg = "'M' cannot follow 'CM'.": Exit Function
    If AFollowsBInC("D", "CM", pstrRN) Then pstrMsg = "'D' cannot follow 'CM'.": Exit Function
 
    ' Once a letter has been used as a subtraction modifier, it cannot appear again in the
    ' string - so C cannot follow CD or CM, X cannot follow XL or XC, and I cannot follow
    ' IV or IX.

    If AFollowsBInC("C", "CD", pstrRN) Then pstrMsg = "'C' cannot follow 'CD'.": Exit Function
    If AFollowsBInC("C", "CM", pstrRN) Then pstrMsg = "'C' cannot follow 'CD'.": Exit Function
    If AFollowsBInC("X", "XL", pstrRN) Then pstrMsg = "'X' cannot follow 'XL'.": Exit Function
    If AFollowsBInC("X", "XC", pstrRN) Then pstrMsg = "'X' cannot follow 'XL'.": Exit Function
    If AFollowsBInC("I", "IV", pstrRN) Then pstrMsg = "'I' cannot follow 'IV'.": Exit Function
    If AFollowsBInC("I", "IX", pstrRN) Then pstrMsg = "'I' cannot follow 'IV'.": Exit Function
 
    ' Once I, X, or C (or their "5-counterparts" V, L, and D) appears in a string, the I, X, or
    ' C cannot subsequently be used as subtraction modifiers - so IV or IX cannot follow I or V,
    ' XL or XC cannot follow X or L, and CD or CM cannot follow C or D.

    If AFollowsBInC("IV", "I", pstrRN) Then pstrMsg = "'IV' cannot follow 'I'.": Exit Function
    If AFollowsBInC("IX", "I", pstrRN) Then pstrMsg = "'IX' cannot follow 'I'.": Exit Function
    If AFollowsBInC("IX", "V", pstrRN) Then pstrMsg = "'IX' cannot follow 'V'.": Exit Function
    If AFollowsBInC("XL", "X", pstrRN) Then pstrMsg = "'XL' cannot follow 'X'.": Exit Function
    If AFollowsBInC("XC", "X", pstrRN) Then pstrMsg = "'XC' cannot follow 'X'.": Exit Function
    If AFollowsBInC("XC", "L", pstrRN) Then pstrMsg = "'XC' cannot follow 'L'.": Exit Function
    If AFollowsBInC("CD", "C", pstrRN) Then pstrMsg = "'CD' cannot follow 'C'.": Exit Function
    If AFollowsBInC("CM", "C", pstrRN) Then pstrMsg = "'CM' cannot follow 'C'.": Exit Function
    If AFollowsBInC("CM", "D", pstrRN) Then pstrMsg = "'CM' cannot follow 'D'.": Exit Function

    ValidRomanInput = True

End Function

Private Function GetSubstringCount(ByVal pstrMainString As String, ByVal pstrSubstring As String) As Long

    Dim lngX As Long
    Dim lngY As Long
 
    If pstrMainString = "" Then
        GetSubstringCount = 0
    Else
        lngX = InStr(1, pstrMainString, pstrSubstring, vbBinaryCompare)
        If lngX = 0 Then
            GetSubstringCount = 0
        Else
            lngX = 0
            For lngY = 1 To Len(pstrMainString)
                If Mid$(pstrMainString, lngY, Len(pstrSubstring)) = pstrSubstring Then
                    lngX = lngX + 1
                End If
            Next lngY
            GetSubstringCount = lngX
        End If
    End If

End Function

Private Function AFollowsBInC(pstrA As String, pstrB As String, pstrC As String) As Boolean

    Dim lngTestPos  As Long
    lngTestPos = InStr(pstrC, pstrB)
    If lngTestPos > 0 Then
        If InStr(lngTestPos + Len(pstrB), pstrC, pstrA, vbTextCompare) Then
            AFollowsBInC = True
        Else
            AFollowsBInC = False
        End If
    Else
        AFollowsBInC = False
    End If
    
End Function


11. Simpan hasil pekerjaan Anda dan jalankan program.


Demikianlah Source Code dan Tutorial Cara Membuat Aplikasi Converter Angka Number ke Angka Romawi Menggunakan Visual Basic 6.0. Selamat mencoba semoga berhasil
Untuk mendapat notifikasi setiap artikel terbaru, masukkan e-mail anda disini
Selanjutnya cek e-mail anda untuk verifikasi.

Silahkan tuliskan komentar relevan Anda dengan jelas dan sopan, sesuai dengan topik postingan tentang "" pada halaman dibawah ini.

0 Response to "Source Code Aplikasi Converter Angka Number ke Angka Romawi di VB6"

Post a Comment

Iklan Atas Artikel

Iklan Tengah Artikel 1

Iklan Tengah Artikel 2


Iklan Bawah Artikel