|
|
|
|
|
|
|
|
|
|
|
 |
|
|||||||||||||||||||||||||||||||||||||||||||||||||||||||
|
||||||||||||||||||||||||||||||||||||||||||||||||||||||||
 |
||||||||||||||||||||||||||||||||||||||||||||||||||||||||
|
|
||
| Visual Basic Helper Routines Pure VB: Converting Numbers to Roman Numerals (and Back) |
||
| Posted: | Monday March 25, 2002 | |
| Updated: | Monday December 26, 2011 | |
| Applies to: | VB4-32, VB5, VB6 | |
| Developed with: | VB6, Windows XP | |
| OS restrictions: | None | |
| Author: | Ian Williams | |
|
Related: |
Pure VB: Converting Numbers to Fractions Pure VB: Converting Numbers to Roman Numerals (and Back) Pure VB: Implementing a Number-To-Text Conversion Function |
|
| Prerequisites |
| None. |
|
|
 Although
not as popular as the request for a routine to convert a numeric value
into a textual representation, conversion to Roman Numerals still
receives considerable interest. This method, posted by Ian Williams in
September 2001 to the comp.lang.vb.* newsgroup demonstrates the conversion
of Arabic values both to and from Roman Numerals.The number-to-roman method is straightforward. The numeric value is dissected into its constituent ones, tens, hundreds and thousands, then uses VB's String function to create a string representing the constituent values. Where a value borders a Roman Numeral transition point, additional checks are made to determine whether the value is only one more or less than the transition point, and the appropriate two-letter code is added. In the roman-to-number routine, the Roman string is converted into a tokenized string, then each token is compared with adjacent tokens to determine the next total value of similar tokens. The result is multiplied by the token value and assigned to a temp variable, which in turn is assigned to the function result. I have made a couple of changes to the author's original routine to improve reading as an HTML page. |
| BAS Module Code |
| None. |
|
|
| Form Code |
|
| To a form add a listbox (List1) and a command button (Command1) along with the following: |
|
|
Option Explicit '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Copyright ©1996-2011 VBnet/Randy Birch, All Rights Reserved. ' Some pages may also contain other copyrights by the author. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Distribution: You can freely use this code in your own ' applications, but you may not reproduce ' or publish this code on any web site, ' online service, or distribute as source ' on any media without express permission. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Const LB_SETTABSTOPS As Long = &H192
Private Sub Form_Load()
ReDim TabArray(0 To 1) As Long
TabArray(0) = 41
TabArray(1) = 103
'set list tabstops
Call SendMessage(List1.hwnd, LB_SETTABSTOPS, 0&, ByVal 0&)
Call SendMessage(List1.hwnd, LB_SETTABSTOPS, 2&, TabArray(0))
Randomize Time
Command1.Caption = "Convert Values"
End Sub
Private Sub Command1_Click()
Dim vArabic As Long
Dim sRoman As String
Dim vArabicBack As Long
List1.Clear
'create 20 random Arabic and Roman values
Do
'create a random number
vArabic = Int(Rnd(1) * 2002) + 1
'create Roman Numeral from the value
sRoman = NumberToRoman(vArabic)
'recreate Arabic value from the Roman
vArabicBack = RomanToNumber(sRoman)
'display the three in the list
List1.AddItem vArabic & vbTab & _
sRoman & vbTab & _
vArabicBack
Loop Until List1.ListCount = 20
End Sub
Private Function NumberToRoman(nArabicValue As Long) As String
Dim nThousands As Long
Dim nFiveHundreds As Long
Dim nHundreds As Long
Dim nFifties As Long
Dim nTens As Long
Dim nFives As Long
Dim nOnes As Long
Dim tmp As String
'take the value passed and split it out
'to values representing the number of
'ones, tens, hundreds, etc
nOnes = nArabicValue
nThousands = nOnes \ 1000
nOnes = nOnes - nThousands * 1000
nFiveHundreds = nOnes \ 500
nOnes = nOnes - nFiveHundreds * 500
nHundreds = nOnes \ 100
nOnes = nOnes - nHundreds * 100
nFifties = nOnes \ 50
nOnes = nOnes - nFifties * 50
nTens = nOnes \ 10
nOnes = nOnes - nTens * 10
nFives = nOnes \ 5
nOnes = nOnes - nFives * 5
'using VB's String function, create
'a series of strings representing
'the number of each respective denomination
tmp = String(nThousands, "M")
'handle those cases where the denominator
'value is on either side of a roman numeral
If nHundreds = 4 Then
If nFiveHundreds = 1 Then
tmp = tmp & "CM"
Else
tmp = tmp & "CD"
End If
Else
'not a 4, so create the string
tmp = tmp & String(nFiveHundreds, "D") & String(nHundreds, "C")
End If
If nTens = 4 Then
If nFifties = 1 Then
tmp = tmp & "XC"
Else
tmp = tmp & "XL"
End If
Else
tmp = tmp & String(nFifties, "L") & String(nTens, "X")
End If
If nOnes = 4 Then
If nFives = 1 Then
tmp = tmp & "IX"
Else
tmp = tmp & "IV"
End If
Else
tmp = tmp & String(nFives, "V") & String(nOnes, "I")
End If
NumberToRoman = tmp
End Function
Private Function RomanToNumber(ByVal strRoman As String) As Long
Dim cnt As Long
Dim strLen As Long
Dim nChar As Long
Dim nNextChar As Long
Dim nNextChar2 As Long
Dim tmpVal As Long
'convert to lower case, and check for
'any invalid strings
strRoman = LCase(strRoman)
If InStr(strRoman, "iiii") Or _
InStr(strRoman, "xxxx") Or _
InStr(strRoman, "cccc") Or _
InStr(strRoman, "vv") Or _
InStr(strRoman, "ll") Or _
InStr(strRoman, "dd") Then
'something's fishy, so bail
RomanToNumber = -1
Exit Function
End If
'for each character in the roman numeral,
'tokenize the character by changing it
'to a numeric representation. For example,
'the Roman Numeral 1995 (MCMXCV) is
'represented by the tokenized string
'"757352"
strLen = Len(strRoman)
For cnt = 1 To strLen
Select Case Mid$(strRoman, cnt, 1)
Case "i": Mid$(strRoman, cnt, 1) = 1
Case "v": Mid$(strRoman, cnt, 1) = 2
Case "x": Mid$(strRoman, cnt, 1) = 3
Case "l": Mid$(strRoman, cnt, 1) = 4
Case "c": Mid$(strRoman, cnt, 1) = 5
Case "d": Mid$(strRoman, cnt, 1) = 6
Case "m": Mid$(strRoman, cnt, 1) = 7
End Select
Next
For cnt = 1 To strLen
'obtain the token for the current character
nChar = CInt(Mid$(strRoman, cnt, 1))
'in order to properly sum the tokens,
'the next two tokens are also needed
If cnt < strLen Then
nNextChar = CInt(Mid$(strRoman, cnt + 1, 1))
If cnt < strLen - 1 Then
nNextChar2 = CInt(Mid$(strRoman, cnt + 2, 1))
Else
nNextChar2 = 0
End If
'based on the retrieved token value,
'calculate a temp value based on it
'and the subsequent tokens
Select Case nChar
Case 7: tmpVal = GetTmpVal2(nChar, _
nNextChar, _
nNextChar2, _
tmpVal, _
cnt, 1000)
Case 6: tmpVal = GetTmpVal2(nChar, _
nNextChar, _
nNextChar2, _
tmpVal, _
cnt, 500)
Case 5: tmpVal = GetTmpVal2(nChar, _
nNextChar, _
nNextChar2, _
tmpVal, _
cnt, 100)
Case 4: tmpVal = GetTmpVal2(nChar, _
nNextChar, _
nNextChar2, _
tmpVal, _
cnt, 50)
Case 3: tmpVal = GetTmpVal2(nChar, _
nNextChar, _
nNextChar2, _
tmpVal, _
cnt, 10)
Case 2: tmpVal = GetTmpVal2(nChar, _
nNextChar, _
nNextChar2, _
tmpVal, _
cnt, 5)
Case 1: tmpVal = GetTmpVal2(nChar, _
nNextChar, _
nNextChar2, _
tmpVal, _
cnt, 1)
End Select
Else
tmpVal = tmpVal + ConvertValue(nChar)
End If
If tmpVal = -1 Then Exit For
Next
RomanToNumber = tmpVal
End Function
Private Function GetTmpVal2(nChar As Long, _
nNextChar As Long, _
nNextChar1 As Long, _
tmpVal As Long, _
cnt As Long, _
intValue As Long) As Long
If nNextChar > nChar Then
If ((nNextChar - nChar = 1 And _
(nChar <> 2 And nChar <> 6)) _
Or (nNextChar - nChar = 2 And _
(nNextChar <> 4 And nNextChar <> 6))) _
And nNextChar1 < nNextChar _
And nNextChar1 <> nChar Then
tmpVal = tmpVal + ConvertValue(nNextChar) - intValue
cnt = cnt + 1
Else
tmpVal = -1
End If
Else
tmpVal = tmpVal + intValue
End If
GetTmpVal2 = tmpVal
End Function
Private Function ConvertValue(ByVal nVal As Long) As Long
Select Case nVal
Case 7: ConvertValue = 1000
Case 6: ConvertValue = 500
Case 5: ConvertValue = 100
Case 4: ConvertValue = 50
Case 3: ConvertValue = 10
Case 2: ConvertValue = 5
Case 1: ConvertValue = 1
End Select
End Function |
| Comments |
|
|
|
|
|
|||||
|
|||||
|
|
|||||
|
Copyright ©1996-2011 VBnet and Randy Birch. All Rights Reserved. |
 |
