Roman and Arabic Numbers Conversions

[anhn]

There were many people (including in these forums) provided many different ways to convert back and fort between Roman and Arabic numbers.

Here is my version if you want it short: (Don't complain, I am lazy to write full comments)

Function RomanToArabic(ByVal Roman As String) As Integer
    '-- Convert Roman number to Arabic number
    '-- Return -32768 as an error flag if Roman string is invalid
    Dim i       As Integer
    Dim Unit    As Integer
    Dim OldUnit As Integer

    OldUnit = 1000
    For i = 1 To Len(Roman)
        Select Case UCase(Mid$(Roman, i, 1))
            Case "I":  Unit = 1
            Case "V":  Unit = 5
            Case "X":  Unit = 10
            Case "L":  Unit = 50
            Case "C":  Unit = 100
            Case "D":  Unit = 500
            Case "M":  Unit = 1000
            Case Else: '-- unaccepted Roman digit
                RomanToArabic = -32768
                Exit Function
        End Select
        If Unit > OldUnit Then RomanToArabic = RomanToArabic - 2 * OldUnit
        RomanToArabic = RomanToArabic + Unit
        OldUnit = Unit
    Next i
End Function

Function ArabicToRoman(ByVal Arabic As Integer) As String
    '-- Convert Arabic number to Roman nunber
    Const R100 = ",C,CC,CCC,CD,D,DC,DCC,DCCC,CM"
    Const R10 = ",X,XX,XXX,XL,L,LX,LXX,LXXX,XC"
    Const R1 = ",I,II,III,IV,V,VI,VII,VIII,IX"
    
    If Arabic < 0 Then      '-- this is not a proper way but
        ArabicToRoman = "-" '   provides a way to deal with
        Arabic = -Arabic    '   negative numbers instead of
    End If                  '   raising an error
    ArabicToRoman = ArabicToRoman & String$(Arabic \ 1000, "M")
    Arabic = Arabic Mod 1000
    ArabicToRoman = ArabicToRoman & Split(R100, ",")(Arabic \ 100)
    Arabic = Arabic Mod 100
    ArabicToRoman = ArabicToRoman & Split(R10, ",")(Arabic \ 10)
    Arabic = Arabic Mod 10
    ArabicToRoman = ArabicToRoman & Split(R1, ",")(Arabic)
End Function

[pstraton]

(deleted)

[pstraton]

Here's my fairly optimized version:

Function RomanToArabic(RomanStr As String) As Long
    '
    'If a valid roman numeral string is specified, returns the equivalent arabic number value, otherwise returns
    'an error value of -1.  Handles both upper-case and lower-case roman numerals.
    '
    'NOTE: This algorithm assumes that the specified roman numeral string is a valid, left to right descending
    'sequence.  Nonsensical roman numeral-like strings will generally produce nonsensical results.
    '
    'Author: Peter Straton
    '
    '*************************************************************************************************************
    
    Const DOT As Byte = 46
    Const UC_I As Byte = 73, LC_i As Byte = 105
    Const UC_V As Byte = 86, LC_v As Byte = 118
    Const UC_X As Byte = 88, LC_x As Byte = 120
    Const UC_L As Byte = 76, LC_l As Byte = 108
    Const UC_C As Byte = 67, LC_c As Byte = 99
    Const UC_D As Byte = 68, LC_d As Byte = 100
    Const UC_M As Byte = 77, LC_m As Byte = 109
    
    Dim i As Integer
    Dim ByteVals() As Byte
    Dim CharArabicVal As Integer
    Dim PrevCharArabicVal As Integer

    ByteVals = RomanStr 'Direct assignment of String to Byte array works

    For i = LBound(ByteVals) To UBound(ByteVals) Step 2 'Skip each double-byte's upper byte
    
        'Get the next roman character's arabic number value
        
        Select Case ByteVals(i)   'For optimized execution, case sequence is in generally most-probable order
        Case UC_I, LC_i: CharArabicVal = 1
        Case UC_V, LC_v: CharArabicVal = 5
        Case UC_X, LC_x: CharArabicVal = 10
        Case UC_M, LC_m: CharArabicVal = 1000
        Case UC_C, LC_c: CharArabicVal = 100
        Case UC_L, LC_l: CharArabicVal = 50
        Case UC_D, LC_d: CharArabicVal = 500
        Case DOT:        CharArabicVal = 0   'Ignore possible appended period character (e.g. outline syntax)
        Case Else
            RomanToArabic = -1  'Found an invalid roman character, return error condition
            Exit Function
        End Select
        
        RomanToArabic = RomanToArabic + CharArabicVal 'Add in the new value
        If CharArabicVal > PrevCharArabicVal Then
            'The current character's Arabic value is greater than the previous character's value, so subtract
            'out the previous character's value twice: once to remove its previously presumed, erroneous
            'addition to the total and once to implement its subtractive notation, indicated by its position
            'to the left of the current, greater-valued character .
            
            RomanToArabic = RomanToArabic - 2 * PrevCharArabicVal
        End If

        PrevCharArabicVal = CharArabicVal
    Next i
End Function