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

 
 

PayPal Link
Make payments with PayPal - it's fast, free and secure!

 
 
 
 

Copyright 1996-2011 VBnet and Randy Birch. All Rights Reserved.
Terms of Use  |  Your Privacy

 

Hit Counter