juanjespar
Jun 29, 2009, updated at 07:30:17 (UTC)
view4341
view12
0
Goto Top

Arabische Zahlen in Römische Rechnen in VB6

GermansolvedQuestionVB for ApplicationsDevelopment

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
comment-contentCommentShareShare
Share on Facebook Share on Twitter Share on Reddit Share on Linkedin

Content-Key: 119278

Url: https://administrator.de/contentid/119278

Printed on: April 16, 2024 at 17:04 o'clock

12 Comments
Latest comment
Goto Top
Member: TsukiSan
TsukiSan Jun 29, 2009 at 10:02:53 (UTC)
Goto Top
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
Member: Logan000
Logan000 Jun 29, 2009 at 14:32:04 (UTC)
Goto Top
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.
Mitglied: 76109
76109 Jun 30, 2009 at 06:39:26 (UTC)
Goto Top
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
Mitglied: 76109
76109 Jun 30, 2009 at 07:24:56 (UTC)
Goto Top
Hallo zusammen!

Code nochmal entfernt. Habe noch einen klitzekleinen Fehler gefunden.face-smile

Gruß Dieter
Mitglied: 76109
76109 Jun 30, 2009 at 08:44:15 (UTC)
Goto Top
Hallo zusammen!

So, jetzt müsste es funktionieren. Habe beim letzten Code die 5er-Reihen übersehen.face-smile
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]
Member: Logan000
Logan000 Jun 30, 2009 at 09:43:49 (UTC)
Goto Top
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.
Mitglied: 76109
76109 Jun 30, 2009 at 11:05:13 (UTC)
Goto Top
Hallo Logan000!

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

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
Member: JuanJespar
JuanJespar Jun 30, 2009 at 12:45:02 (UTC)
Goto Top
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
Mitglied: 76109
76109 Jun 30, 2009 at 13:50:59 (UTC)
Goto Top
Hallo JuanJespar!

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

Aber, wozu braucht man sowas eigenlich?

Gruß Dieter
Member: JuanJespar
JuanJespar Jun 30, 2009 at 14:01:55 (UTC)
Goto Top
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
Mitglied: 76109
76109 Jun 30, 2009 at 15:01:34 (UTC)
Goto Top
Hallo JuanJespar!

Danke für die Antwort.

Na, da kannst Du ja jetzt Punkte sammelnface-smile Und für Deine Ausbildung drücke ich Dir mal die Daumen.

Gruß Dieter
Member: JuanJespar
JuanJespar Jul 01, 2009 at 09:37:35 (UTC)
Goto Top
Hallo Didi.

Ja danke das hoffe ich auch.

Vlt höhren wir ja noch öfters von einander, scheinst ja schon recht gut bewandert in VB zu sein
GermansolvedQuestionVB for ApplicationsDevelopment
Hotly discussed
DaniEnd of Support dates for Office 2016, 2019 Apps und Productivity ServersDani - 1 Comment