Arabische Zahlen in Römische Rechnen in VB6

gelöstFrage VB for Applications Entwicklung

Hab das Problem das ich eine Rechenfunktion von Arabischen in Römischen Zahlen schreiben muss.
umgedreht hab ich schon.
Hat jemand da nen ansatz?
mfg
Juan

Function von Römisch in Arabisch

Function Rom2Arab(ByVal RZahl As String) As Long
Dim i As Integer
Dim lngTeilWert As Long
Dim lngTeilWert2 As Long
Dim lngGesamtWert As Long
    
    lngTeilWert = 0
    lngTeilWert2 = 0
    lngGesamtWert = 0
    
    For i = 1 To Len(RZahl)
        Select Case Mid(RZahl, i, 1)
            Case "M"  
                lngTeilWert = 1000
            Case "D"  
                lngTeilWert = 500
            Case "C"  
                lngTeilWert = 100
            Case "L"  
                lngTeilWert = 50
            Case "X"  
                lngTeilWert = 10
            Case "V"  
                lngTeilWert = 5
            Case "I"  
                lngTeilWert = 1
        End Select
        
        If lngTeilWert2 < lngTeilWert Then
            lngGesamtWert = lngGesamtWert - lngTeilWert2 * 2 + lngTeilWert
        Else
            lngGesamtWert = lngGesamtWert + lngTeilWert
        End If
        lngTeilWert2 = lngTeilWert
    Next i
    
    Rom2Arab = lngGesamtWert
End Function

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 119278

Url: https://administrator.de/forum/arabische-zahlen-in-roemische-rechnen-in-vb6-119278.html

Ausgedruckt am: 22.04.2025 um 10:04 Uhr

12 Kommentare

Neuester Kommentar

auch ein fröhliches Hallo,

wie wäre es mit

.        Select Case Mid(RZahl, i, 1) 
            Case 1000
                lngTeilWert = "M"   
            Case 500 
                lngTeilWert = "D"   
            Case 100 
                lngTeilWert = "C"  
            Case 50 
                lngTeilWert = "L"  
            Case 10 
                lngTeilWert = "X"  
            Case 5 
                lngTeilWert = "V"  
            Case 1 
                lngTeilWert = "I"  
        End Select 

???????

Gruß

Tsuki

Moin Moin

Sorry Tsuki ganz so einfach ist das nun auch nicht.

Ich hab diese Funktion mal vor längerer Zeit geschrieben.
Soweit ich das sagen kann funktioniert sie ganz hervorragend.
(Falls jemand eine elegqanteren/ besserenWeg hat, immer her damit)

Public Function NumInRoman(intArabic As Long) As String

    Dim szRoman As String
    Dim Roman As Variant
    Dim Arabic As Variant
    Dim i As Integer
    Dim szArabic As String
    Dim szPotenz As String
    Dim intPotenz As Long
    Dim intAnz As Integer
    
On Error Resume Next
    
    If intArabic = 0 Then Exit Function
     
    Roman = Array("I", "V", "X", "L", "C", "D", "M")  
    Arabic = Array(1, 5, 10, 50, 100, 500, 1000)
    
    szArabic = CStr(intArabic)
    szPotenz = Left(szArabic, 1)
    While Len(szPotenz) < Len(szArabic)
        szPotenz = szPotenz & "0"  
    Wend
    intPotenz = CLng(szPotenz)
    
    i = 6
    While i >= 0
        If intPotenz = Arabic(i) Then
            szRoman = Roman(i) & NumInRoman(intArabic - intPotenz)
            GoTo Exithandler
        End If
        i = i - 1
    Wend
    If (intPotenz + Arabic(4)) Mod 100 = 0 Then
        szRoman = Roman(4) & NumInRoman(intArabic + Arabic(4))
        GoTo Exithandler
    End If
    If (intPotenz + Arabic(2)) Mod 10 = 0 Then
        szRoman = Roman(2) & NumInRoman(intArabic + Arabic(2))
        GoTo Exithandler
    End If
    If (intPotenz + Arabic(0)) Mod 10 = 0 Then
        szRoman = Roman(0) & NumInRoman(intArabic + Arabic(0))
        GoTo Exithandler
    End If
    i = Len(szArabic)
    Select Case Left(szPotenz, 1)
    Case "9"  
        szRoman = Roman(i - 2) & Roman(i) & NumInRoman(intArabic - intPotenz)
        GoTo Exithandler
    Case "4"  
        szRoman = Roman(i - 1) & Roman(i) & NumInRoman(intArabic - intPotenz)
        GoTo Exithandler
    Case Is > "4"  
        szRoman = Roman(i)
        intAnz = Left(szPotenz, 1) Mod 5
        While intAnz > 0
            szRoman = szRoman & Roman(i - 1)
            intAnz = intAnz - 1
        Wend
        szRoman = szRoman & NumInRoman(intArabic - intPotenz)
        GoTo Exithandler
    Case Else
        szRoman = Roman(i - 1) & NumInRoman(intArabic - Arabic(i - 1))
    End Select
Exithandler:
    NumInRoman = szRoman
    Err.Clear                                                           ' Evtl. Error clearen  
End Function

Gruß L.

Hallo Logan000!

Ich bastle gerade an einem Code und beim testen, zu dem ich Deinen Code zur Controlle verwende, ist mir aufgefallen, dass Dein Code bei Zahlen ab 2000 austickt und nur noch Das Zeichen "C" schreibt. Bei der Zahl 399 zeigt er das Ergebnis (CCDXCIX) und bei Zahl 20 (XXXL)?

Gruß Dieter

Hallo zusammen!

Code nochmal entfernt. Habe noch einen klitzekleinen Fehler gefunden.

Gruß Dieter

Hallo zusammen!

So, jetzt müsste es funktionieren. Habe beim letzten Code die 5er-Reihen übersehen.

Function ArabicToRoman(ByVal Zahl As Integer) As String
    
    Dim Roman As Variant, Arabic As Variant, Summen As Variant
    Dim i As Integer, x As Integer, Test1 As Integer, Test2 As Integer
        
    Summen = Array(0, 0, 0, 0, 0, 0, 0)
    Arabic = Array(1000, 500, 100, 50, 10, 5, 1, 1)
    Roman = Array("M", "D", "C", "L", "X", "V", "I", "")  
                 
    If Zahl <= 0 Or Zahl > 3999 Then Exit Function
    
    For i = 0 To UBound(Summen)
        Test1 = Zahl \ Arabic(i):  Test2 = Zahl \ Arabic(i + 1):  Zahl = Zahl Mod Arabic(i) 
       'Für Div ohne Rest mit \ anstatt /  
 
        If Test2 = 9 And Not (Roman(i + 1) = "D" Or Roman(i + 1) = "L" Or Roman(i + 1) = "V") Then  
            Summen(i + 1) = Test2:  Zahl = Zahl Mod Arabic(i + 1): i = i + 1
        Else
            Summen(i) = Test1
        End If
            
        If Zahl = 0 Then Exit For
    Next
   
    For i = 0 To UBound(Summen)
        If Summen(i) = 4 Then
            Summen(i) = 0:  ArabicToRoman = ArabicToRoman & Roman(i) & Roman(i - 1)
        ElseIf Summen(i) = 9 Then
            Summen(i) = 0:  ArabicToRoman = ArabicToRoman & Roman(i) & Roman(i - 2)
        ElseIf Summen(i) > 0 Then
            For x = 1 To Summen(i):  ArabicToRoman = ArabicToRoman & Roman(i):  Next
        End If
    Next
End Function

Gruß Dieter

[edit] Auf Anregung von Logan000, die Zahlen auf max 3999 begrenzt. [/edit]

Moin Moin

Der Code ist super, Dieter.
Ich frag mich gerade, was ich damals fürn Kot produziert habe.

Eine Anmerkung zu deiner Funktion. Du soltest in Zeile 10, Zahlen über 3999 auschließen:

...
If Zahl <= 0 Or Zahl > 3999Then Exit Function 
...

Da bei Römischen Zahlen sich jedes Zeichen max. 3x wiederholen darf, wäre das eigentlich auch die Größte römische Zahl.
Falls Du größere Zahlen zulassen möchtest, must du in Zeile 27 was machen, denn da würde die Funktion bei Zahl = 4000 aussteigen.

Gruß L.

Hallo Logan000!

Danke für den Hinweis. Soweit habe ich nicht getestet.

Also, ich muss gestehen, dass ich Anfangs auch noch ganz schön im Nebel Stand. Aber dann kam mir doch noch eine kleine Erleuchtung.

Am Anfang, als ich ein paar Zahlen in Deinen Code eingegeben hatte, stimmte es noch. Erst als ich mit einer For-Schleife in Hunderter Schritten, beide Ergebnisse in Debug.Print verglichen habe, ist mir der Fehler aufgefallen.

Gruß Dieter

Danke Leute.

Die Function sieht wenigstens jetz plausibel aus.
i hab mich schon halb verrückt versucht an dem Code, andere Rechnung von Römisch auf Arabisch fand ich garnicht so schlimm aba von zahlen auf Römischen is schon komisch.

trotzdem thx

Hallo JuanJespar!

Ja, da gebe ich Dir Recht. So aus dem Stehgreif habe ich das auch nicht hinbekommen.

Aber, wozu braucht man sowas eigenlich?

Gruß Dieter

Ich brauche das in meinem Praktikum(hoffentlich bald ausbildung)

ich brauch vba für den einsatz in ErkennungsEngine.

daher muss i erstmal vb lern.das sind meistens Aufgaben die ich von meinen Ausbilder bekomme.

und wenn ich nicht weiter komm kann mann ja mal net fragen.

Gruß Juan