convertire in numeri romani

[amodio]

salve atutti
come posso convertire un numero in romano?

grazie

[iguana13]

Ti metto una mia vecchia funzione:

Piu4000:
num = num + 1
4000:

If num < 1000 Then GoTo 900
If num > 1000 Then
 DecToRom = DecToRom & "M"
 num = num - 1000
 GoTo 4000
End If

900:

If num < 500 Then GoTo 400
If num > 900 Then
 DecToRom = DecToRom & "CM"
 num = num - 900
 GoTo 900
ElseIf num > 800 Then
 DecToRom = DecToRom & "DCCC"
 num = num - 800
 GoTo 900
ElseIf num > 700 Then
 DecToRom = DecToRom & "DCC"
 num = num - 700
 GoTo 900
ElseIf num > 600 Then
 DecToRom = DecToRom & "DC"
 num = num - 600
 GoTo 900
ElseIf num > 500 Then
 DecToRom = DecToRom & "D"
 num = num - 500
 GoTo 900
End If

400:

If num < 100 Then GoTo 90
If num > 400 Then
 DecToRom = DecToRom & "CD"
 num = num - 400
 GoTo 400
ElseIf num > 300 Then
 DecToRom = DecToRom & "CCC"
 num = num - 300
 GoTo 400
ElseIf num > 200 Then
 DecToRom = DecToRom & "CC"
 num = num - 200
 GoTo 400
ElseIf num > 100 Then
 DecToRom = DecToRom & "C"
 num = num - 100
 GoTo 400
End If

90:

If num < 50 Then GoTo 40
If num > 90 Then
 DecToRom = DecToRom & "XC"
 num = num - 90
 GoTo 90
ElseIf num > 80 Then
 DecToRom = DecToRom & "LXXX"
 num = num - 80
 GoTo 90
ElseIf num > 70 Then
 DecToRom = DecToRom & "LXX"
 num = num - 70
 GoTo 90
ElseIf num > 60 Then
 DecToRom = DecToRom & "LX"
 num = num - 60
 GoTo 90
ElseIf num > 50 Then
 DecToRom = DecToRom & "L"
 num = num - 50
 GoTo 90
End If

40:

If num < 10 Then GoTo 9
If num > 40 Then
 DecToRom = DecToRom & "XL"
 num = num - 40
 GoTo 40
ElseIf num > 30 Then
 DecToRom = DecToRom & "XXX"
 num = num - 30
 GoTo 40
ElseIf num > 20 Then
 DecToRom = DecToRom & "XX"
 num = num - 20
 GoTo 40
ElseIf num > 10 Then
 DecToRom = DecToRom & "X"
 num = num - 10
 GoTo 40
End If

9:

If num < 5 Then GoTo 4
If num > 9 Then
 DecToRom = DecToRom & "IX"
 num = num - 9
 GoTo 9
ElseIf num > 8 Then
 DecToRom = DecToRom & "VIII"
 num = num - 8
 GoTo 9
ElseIf num > 7 Then
 DecToRom = DecToRom & "VII"
 num = num - 7
 GoTo 9
ElseIf num > 6 Then
 DecToRom = DecToRom & "VI"
 num = num - 6
 GoTo 9
ElseIf num > 5 Then
 DecToRom = DecToRom & "V"
 num = num - 5
 GoTo 9
End If
4:

If num < 1 Then GoTo Fine
If num > 4 Then
 DecToRom = DecToRom & "IV"
 num = num - 4
 GoTo 4
ElseIf num > 3 Then
 DecToRom = DecToRom & "III"
 num = num - 3
 GoTo 4
ElseIf num > 2 Then
 DecToRom = DecToRom & "II"
 num = num - 2
 GoTo 4
ElseIf num > 1 Then
 DecToRom = DecToRom & "I"
 num = num - 1
 GoTo 4
End If


Fine:

Form1.Text2 = DecToRom

[amodio]

grazie ora provo


noto che ad ogni passaggio
non controlla dove è finito il numero

e non trovo neanche dove esce dalla funzione appena intercetta il numero
ho notato che si chiama decrom la funzione...
se puoi darmi i parametri...( )

cmq grazie dell'aiuto

[iguana13]

Ho rivisto il codice e ti propongo una versione migliore, con un piccolo esempio:

Private Sub Command1_Click()
Text2 = CRomano(CLng(Text1))
End Sub


Public Function CRomano(ByVal Numero As Long) As String
Do Until Numero < 1000
    CRomano = CRomano & "M"
    Numero = Numero - 1000
Loop

If Numero >= 900 Then
    CRomano = CRomano & "CM"
    Numero = Numero - 900
ElseIf Numero >= 500 Then
    CRomano = CRomano & "D"
    Numero = Numero - 500
ElseIf Numero >= 400 Then
    CRomano = CRomano & "CD"
    Numero = Numero - 400
End If
If Numero >= 100 Then
    Do Until Numero < 100
        CRomano = CRomano & "C"
        Numero = Numero - 100
    Loop
End If

If Numero >= 90 Then
    CRomano = CRomano & "XC"
    Numero = Numero - 90
ElseIf Numero >= 50 Then
    CRomano = CRomano & "L"
    Numero = Numero - 50
ElseIf Numero >= 40 Then
    CRomano = CRomano & "XL"
    Numero = Numero - 40
End If
If Numero >= 10 Then
    Do Until Numero < 10
        CRomano = CRomano & "X"
        Numero = Numero - 10
    Loop
End If

If Numero = 9 Then
    CRomano = CRomano & "IX"
    Numero = Numero - 9
ElseIf Numero >= 5 Then
    CRomano = CRomano & "V"
    Numero = Numero - 5
ElseIf Numero = 4 Then
    CRomano = CRomano & "IV"
    Numero = Numero - 4
End If
If Numero >= 1 Then
    Do Until Numero <= 0
        CRomano = CRomano & "I"
        Numero = Numero - 1
    Loop
End If

If Numero <> 0 Then MsgBox "Errore!"
End Function

La funzione CRomano() accetta per parametro un numero intero e lo restituisce come stringa in cifre romane.

[amodio]

uao grazie