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 :
Cara Membuat 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.
Demikian tip Cara Membuat Aplikasi Converter Angka Number ke Angka Romawi dengan VB6. Selamat mencoba semoga berhasil
No comments:
Post a Comment