[SNIPPET] Decimal a Romano

[Karcrack]

Discutiendo con un amigo; la forma mas corta que se me ocurrio:

Código (vb) [Seleccionar] Expandir

Public Function DecToRoman(ByVal lNum As Long) As String
    DecToRoman = Choose(((lNum Mod 10) / 1) + 1, "", "I", "II", "III", "IV", "V", "VI", "VII", "VIII", "IX")
    lNum = lNum - (lNum Mod 10)
    DecToRoman = Choose(((lNum Mod 100) / 10) + 1, "", "X", "XX", "XXX", "XL", "L", "LX", "LXX", "LXXX", "XC") & DecToRoman
    lNum = lNum - (lNum Mod 100)
    DecToRoman = String$((lNum \ 1000), "M") & Choose(((lNum Mod 1000) / 100) + 1, "", "C", "CC", "CCC", "CD", "D", "DC", "DCC", "DCCC", "CM") & DecToRoman
End Function

Saludos

[agus0]

✗ Gracias ✗

[Psyke1]

Buena Karcrack, esta muy claro de entender.
No te gusta más así?

Código (vb) [Seleccionar] Expandir

Public Function DecToRoman(ByVal lNum As Long) As String
    DecToRoman = Choose(((lNum Mod 10) / 1) + 1, "", "I", "II", "III", "IV", "V", "VI", "VII", "VIII", "IX")
    lNum = lNum - (lNum Mod 10)
    If lNum Then
        DecToRoman = Choose(((lNum Mod 100) / 10) + 1, "", "X", "XX", "XXX", "XL", "L", "LX", "LXX", "LXXX", "XC") & DecToRoman
        lNum = lNum - (lNum Mod 100)
        If lNum Then
            DecToRoman = String$((lNum \ 1000), "M") & Choose(((lNum Mod 1000) / 100) + 1, "", "C", "CC", "CCC", "CD", "D", "DC", "DCC", "DCCC", "CM") & DecToRoman
        End If
    End If
End Function
De esta manera si es el 7 o el 46 (por ej) no sigue comprobando.
Por cierto y RomanToDec() que?

DoEvents!

[Karcrack]

Lo importante es hacerlo corto, no rapido ni nada similar En cuanto a RomanToDec... no tiene utilidad

[79137913]

HOLA!!!

Aunque no tenga utilidad, seguro alguien lo va a buscar y va a revivir el post asi que:

RomanToDecimal:

Código (vb) [Seleccionar] Expandir

Private Function RomanToDecimal(RomNum As String) As String

    Dim VectorRom()         As Integer 'Lo lleno con los valores de las letras
    Dim Tam                 As Integer 'Tamaño del numero Romano
    Dim X                   As Integer 'Para los Bucles
    Dim SumaRom             As Integer 'Acumulador
   
    Tam = Len(RomNum)
   
    If Tam = 0 Then
        RomanToDecimal = 0
        Exit Function
    End If
   
    ReDim VectorRom(1 To Tam)
   
    For X = 1 To Tam
        Select Case Mid$(RomNum, X, 1)
            Case "M":   VectorRom(X) = 1000
            Case "D":   VectorRom(X) = 500
            Case "C":   VectorRom(X) = 100
            Case "L":   VectorRom(X) = 50
            Case "X":   VectorRom(X) = 10
            Case "V":   VectorRom(X) = 5
            Case "I":   VectorRom(X) = 1
        End Select
    Next
   
    For X = 1 To Tam
        If X = Tam Then
            SumaRom = SumaRom + VectorRom(X)
        Else
            If VectorRom(X) >= VectorRom(X + 1) Then
                SumaRom = SumaRom + VectorRom(X)
            Else
                SumaRom = SumaRom - VectorRom(X)
            End If
        End If
    Next
   
    RomanToDecimal = CStr(SumaRom)

End Function


GRACIAS POR LEER!!!