Conversión a Romanos

Fecha: 05/DIC/97
Autor: Victor Gonzalez (Maverick)

Convierte un número árabe a número romano.

Esta función es bastante sencilla, le envías un número entero y te devuelve una cadena con el texto que corresponde en números romanos.

Puede ser bastante útil para mostrar información un poco elegante, tipo Copyright (como en la tele).

Function ConvertirRomano(Numero As Integer) As String
    Dim Romano As String
    Dim I As Integer, Digito As Integer, X As Integer
    Dim Cadena As String, CadenaTmp As String
    Dim Simbolo1 As String * 1, Simbolo2 As String * 1, Simbolo3 As String * 1

    Cadena = CStr(Numero)
    For X = 1 To Len(Cadena)
        If Len(Cadena) = 4 Then
            Simbolo1 = "M"
            Simbolo2 = "Q"
            Simbolo3 = "H"
            Digito = CInt(Left$(Cadena, 1))
            Cadena = Right$(Cadena, 3)
        ElseIf Len(Cadena) = 3 Then
            Simbolo1 = "C"
            Simbolo2 = "D"
            Simbolo3 = "M"
            Digito = CInt(Left$(Cadena, 1))
            Cadena = Right$(Cadena, 2)
        ElseIf Len(Cadena) = 2 Then
            Simbolo1 = "X"
            Simbolo2 = "L"
            Simbolo3 = "C"
            Digito = CInt(Left$(Cadena, 1))
            Cadena = Right$(Cadena, 1)
        ElseIf Len(Cadena) = 1 Then
            Simbolo1 = "I"
            Simbolo2 = "V"
            Simbolo3 = "X"
            Digito = CInt(Left$(Cadena, 1))
            Cadena = ""
        End If
        If Digito <= 3 Then
        For I = 1 To Digito
            CadenaTmp = CadenaTmp & Simbolo1
        Next I
        ElseIf Digito < 5 Then
            CadenaTmp = Simbolo1 & Simbolo2
        ElseIf Digito = 5 Then
            CadenaTmp = Simbolo2
        ElseIf Digito <= 8 Then
            CadenaTmp = Simbolo2
            For I = 1 To Digito - 5
                CadenaTmp = CadenaTmp & Simbolo1
            Next I
        ElseIf Digito = 9 Then
            CadenaTmp = Simbolo1 & Simbolo3
        End If
        Romano = Romano & CadenaTmp
        CadenaTmp = ""
    Next X
    ConvertirRomano = Romano
End Function

En principio debe funcionar en cualquier versión de VB, ya que no utiliza ninguna API o instrucción de la raras.

No es ninguna obligación, pero me gustaría que me enviarais un e-mail para saber quien lo esta utilizando o por alguna modificación debido a algún error, más que nada porque me interesa que funcione bien.

Maverick
VictorGon@Nexo.es