Top-Themen

AppleEntwicklungHardwareInternetLinuxMicrosoftMultimediaNetzwerkeOff TopicSicherheitSonstige SystemeVirtualisierungWeiterbildungZusammenarbeit

Aktuelle Themen

Administrator.de FeedbackApache ServerAppleAssemblerAudioAusbildungAuslandBackupBasicBatch & ShellBenchmarksBibliotheken & ToolkitsBlogsCloud-DiensteClusterCMSCPU, RAM, MainboardsCSSC und C++DatenbankenDatenschutzDebianDigitiales FernsehenDNSDrucker und ScannerDSL, VDSLE-BooksE-BusinessE-MailEntwicklungErkennung und -AbwehrExchange ServerFestplatten, SSD, RaidFirewallFlatratesGoogle AndroidGrafikGrafikkarten & MonitoreGroupwareHardwareHosting & HousingHTMLHumor (lol)Hyper-VIconsIDE & EditorenInformationsdiensteInstallationInstant MessagingInternetInternet DomäneniOSISDN & AnaloganschlüsseiTunesJavaJavaScriptKiXtartKVMLAN, WAN, WirelessLinuxLinux DesktopLinux NetzwerkLinux ToolsLinux UserverwaltungLizenzierungMac OS XMicrosoftMicrosoft OfficeMikroTik RouterOSMonitoringMultimediaMultimedia & ZubehörNetzwerkeNetzwerkgrundlagenNetzwerkmanagementNetzwerkprotokolleNotebook & ZubehörNovell NetwareOff TopicOpenOffice, LibreOfficeOutlook & MailPapierkorbPascal und DelphiPeripheriegerätePerlPHPPythonRechtliche FragenRedHat, CentOS, FedoraRouter & RoutingSambaSAN, NAS, DASSchriftartenSchulung & TrainingSEOServerServer-HardwareSicherheitSicherheits-ToolsSicherheitsgrundlagenSolarisSonstige SystemeSoziale NetzwerkeSpeicherkartenStudentenjobs & PraktikumSuche ProjektpartnerSuseSwitche und HubsTipps & TricksTK-Netze & GeräteUbuntuUMTS, EDGE & GPRSUtilitiesVB for ApplicationsVerschlüsselung & ZertifikateVideo & StreamingViren und TrojanerVirtualisierungVisual StudioVmwareVoice over IPWebbrowserWebentwicklungWeiterbildungWindows 7Windows 8Windows 10Windows InstallationWindows MobileWindows NetzwerkWindows ServerWindows SystemdateienWindows ToolsWindows UpdateWindows UserverwaltungWindows VistaWindows XPXenserverXMLZusammenarbeit
GELÖST

Arabische Zahlen in Römische Rechnen in VB6

Frage Entwicklung VB for Applications

Mitglied: JuanJespar

JuanJespar (Level 1) - Jetzt verbinden

29.06.2009, aktualisiert 09:30 Uhr, 3841 Aufrufe, 12 Kommentare

Hab das Problem das ich eine Rechenfunktion von Arabischen in Römischen Zahlen schreiben muss.
umgedreht hab ich schon.
Hat jemand da nen ansatz?
Mit freundlichen Grüßen
Juan

Function von Römisch in Arabisch

01.
Function Rom2Arab(ByVal RZahl As String) As Long 
02.
Dim i As Integer 
03.
Dim lngTeilWert As Long 
04.
Dim lngTeilWert2 As Long 
05.
Dim lngGesamtWert As Long 
06.
     
07.
    lngTeilWert = 0 
08.
    lngTeilWert2 = 0 
09.
    lngGesamtWert = 0 
10.
     
11.
    For i = 1 To Len(RZahl) 
12.
        Select Case Mid(RZahl, i, 1) 
13.
            Case "M" 
14.
                lngTeilWert = 1000 
15.
            Case "D" 
16.
                lngTeilWert = 500 
17.
            Case "C" 
18.
                lngTeilWert = 100 
19.
            Case "L" 
20.
                lngTeilWert = 50 
21.
            Case "X" 
22.
                lngTeilWert = 10 
23.
            Case "V" 
24.
                lngTeilWert = 5 
25.
            Case "I" 
26.
                lngTeilWert = 1 
27.
        End Select 
28.
         
29.
        If lngTeilWert2 < lngTeilWert Then 
30.
            lngGesamtWert = lngGesamtWert - lngTeilWert2 * 2 + lngTeilWert 
31.
        Else 
32.
            lngGesamtWert = lngGesamtWert + lngTeilWert 
33.
        End If 
34.
        lngTeilWert2 = lngTeilWert 
35.
    Next i 
36.
     
37.
    Rom2Arab = lngGesamtWert 
38.
End Function
Mitglied: TsukiSan
29.06.2009 um 12:02 Uhr
....auch ein fröhliches Hallo,

wie wäre es mit
01.
.        Select Case Mid(RZahl, i, 1)  
02.
            Case 1000 
03.
                lngTeilWert = "M"  
04.
            Case 500  
05.
                lngTeilWert = "D"  
06.
            Case 100  
07.
                lngTeilWert = "C" 
08.
            Case 50  
09.
                lngTeilWert = "L" 
10.
            Case 10  
11.
                lngTeilWert = "X" 
12.
            Case 5  
13.
                lngTeilWert = "V" 
14.
            Case 1  
15.
                lngTeilWert = "I" 
16.
        End Select 
???????

Gruß

Tsuki
Bitte warten ..
Mitglied: Logan000
29.06.2009 um 16:32 Uhr
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)
01.
Public Function NumInRoman(intArabic As Long) As String 
02.
 
03.
    Dim szRoman As String 
04.
    Dim Roman As Variant 
05.
    Dim Arabic As Variant 
06.
    Dim i As Integer 
07.
    Dim szArabic As String 
08.
    Dim szPotenz As String 
09.
    Dim intPotenz As Long 
10.
    Dim intAnz As Integer 
11.
     
12.
On Error Resume Next 
13.
     
14.
    If intArabic = 0 Then Exit Function 
15.
      
16.
    Roman = Array("I", "V", "X", "L", "C", "D", "M") 
17.
    Arabic = Array(1, 5, 10, 50, 100, 500, 1000) 
18.
     
19.
    szArabic = CStr(intArabic) 
20.
    szPotenz = Left(szArabic, 1) 
21.
    While Len(szPotenz) < Len(szArabic) 
22.
        szPotenz = szPotenz & "0" 
23.
    Wend 
24.
    intPotenz = CLng(szPotenz) 
25.
     
26.
    i = 6 
27.
    While i >= 0 
28.
        If intPotenz = Arabic(i) Then 
29.
            szRoman = Roman(i) & NumInRoman(intArabic - intPotenz) 
30.
            GoTo Exithandler 
31.
        End If 
32.
        i = i - 1 
33.
    Wend 
34.
    If (intPotenz + Arabic(4)) Mod 100 = 0 Then 
35.
        szRoman = Roman(4) & NumInRoman(intArabic + Arabic(4)) 
36.
        GoTo Exithandler 
37.
    End If 
38.
    If (intPotenz + Arabic(2)) Mod 10 = 0 Then 
39.
        szRoman = Roman(2) & NumInRoman(intArabic + Arabic(2)) 
40.
        GoTo Exithandler 
41.
    End If 
42.
    If (intPotenz + Arabic(0)) Mod 10 = 0 Then 
43.
        szRoman = Roman(0) & NumInRoman(intArabic + Arabic(0)) 
44.
        GoTo Exithandler 
45.
    End If 
46.
    i = Len(szArabic) 
47.
    Select Case Left(szPotenz, 1) 
48.
    Case "9" 
49.
        szRoman = Roman(i - 2) & Roman(i) & NumInRoman(intArabic - intPotenz) 
50.
        GoTo Exithandler 
51.
    Case "4" 
52.
        szRoman = Roman(i - 1) & Roman(i) & NumInRoman(intArabic - intPotenz) 
53.
        GoTo Exithandler 
54.
    Case Is > "4" 
55.
        szRoman = Roman(i) 
56.
        intAnz = Left(szPotenz, 1) Mod 5 
57.
        While intAnz > 0 
58.
            szRoman = szRoman & Roman(i - 1) 
59.
            intAnz = intAnz - 1 
60.
        Wend 
61.
        szRoman = szRoman & NumInRoman(intArabic - intPotenz) 
62.
        GoTo Exithandler 
63.
    Case Else 
64.
        szRoman = Roman(i - 1) & NumInRoman(intArabic - Arabic(i - 1)) 
65.
    End Select 
66.
Exithandler: 
67.
    NumInRoman = szRoman 
68.
    Err.Clear                                                           ' Evtl. Error clearen 
69.
End Function
Gruß L.
Bitte warten ..
Mitglied: 76109
30.06.2009 um 08:39 Uhr
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
Bitte warten ..
Mitglied: 76109
30.06.2009 um 09:24 Uhr
Hallo zusammen!

Code nochmal entfernt. Habe noch einen klitzekleinen Fehler gefunden.

Gruß Dieter
Bitte warten ..
Mitglied: 76109
30.06.2009 um 10:44 Uhr
Hallo zusammen!

So, jetzt müsste es funktionieren. Habe beim letzten Code die 5er-Reihen übersehen.
01.
Function ArabicToRoman(ByVal Zahl As Integer) As String 
02.
     
03.
    Dim Roman As Variant, Arabic As Variant, Summen As Variant 
04.
    Dim i As Integer, x As Integer, Test1 As Integer, Test2 As Integer 
05.
         
06.
    Summen = Array(0, 0, 0, 0, 0, 0, 0) 
07.
    Arabic = Array(1000, 500, 100, 50, 10, 5, 1, 1) 
08.
    Roman = Array("M", "D", "C", "L", "X", "V", "I", "") 
09.
                  
10.
    If Zahl <= 0 Or Zahl > 3999 Then Exit Function 
11.
     
12.
    For i = 0 To UBound(Summen) 
13.
        Test1 = Zahl \ Arabic(i):  Test2 = Zahl \ Arabic(i + 1):  Zahl = Zahl Mod Arabic(i)  
14.
       'Für Div ohne Rest mit \ anstatt / 
15.
  
16.
        If Test2 = 9 And Not (Roman(i + 1) = "D" Or Roman(i + 1) = "L" Or Roman(i + 1) = "V") Then 
17.
            Summen(i + 1) = Test2:  Zahl = Zahl Mod Arabic(i + 1): i = i + 1 
18.
        Else 
19.
            Summen(i) = Test1 
20.
        End If 
21.
             
22.
        If Zahl = 0 Then Exit For 
23.
    Next 
24.
    
25.
    For i = 0 To UBound(Summen) 
26.
        If Summen(i) = 4 Then 
27.
            Summen(i) = 0:  ArabicToRoman = ArabicToRoman & Roman(i) & Roman(i - 1) 
28.
        ElseIf Summen(i) = 9 Then 
29.
            Summen(i) = 0:  ArabicToRoman = ArabicToRoman & Roman(i) & Roman(i - 2) 
30.
        ElseIf Summen(i) > 0 Then 
31.
            For x = 1 To Summen(i):  ArabicToRoman = ArabicToRoman & Roman(i):  Next 
32.
        End If 
33.
    Next 
34.
End Function
Gruß Dieter

[edit] Auf Anregung von Logan000, die Zahlen auf max 3999 begrenzt. [/edit]
Bitte warten ..
Mitglied: Logan000
30.06.2009 um 11:43 Uhr
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:
01.
... 
02.
If Zahl <= 0 Or Zahl > 3999Then Exit Function  
03.
...
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.
Bitte warten ..
Mitglied: 76109
30.06.2009 um 13:05 Uhr
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
Bitte warten ..
Mitglied: JuanJespar
30.06.2009 um 14:45 Uhr
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
Bitte warten ..
Mitglied: 76109
30.06.2009 um 15:50 Uhr
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
Bitte warten ..
Mitglied: JuanJespar
30.06.2009 um 16:01 Uhr
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
Bitte warten ..
Mitglied: 76109
30.06.2009 um 17:01 Uhr
Hallo JuanJespar!

Danke für die Antwort.

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

Gruß Dieter
Bitte warten ..
Mitglied: JuanJespar
01.07.2009 um 11:37 Uhr
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
Bitte warten ..
Neuester Wissensbeitrag
Internet

Unbemerkt - Telekom Netzumschaltung! - BNG - Broadband Network Gateway

(3)

Erfahrungsbericht von ashnod zum Thema Internet ...

Ähnliche Inhalte
Batch & Shell
gelöst Spezielles Batch Problem mit Zahlen 20 + 29 (2)

Frage von narthan zum Thema Batch & Shell ...

Microsoft Office
gelöst Excel VBA Letzte Zelle Suchen dann rechnen und Wert in Zelle Übertragen (3)

Frage von Addi089 zum Thema Microsoft Office ...

Batch & Shell
gelöst Mit DIR-Befehl Zahlen normal literarisch sortieren (14)

Frage von evinben zum Thema Batch & Shell ...

Heiß diskutierte Inhalte
Switche und Hubs
Trunk für 2xCisco Switch. Wo liegt der Fehler? (17)

Frage von JayyyH zum Thema Switche und Hubs ...

Windows Server
Outlook Verbindungsversuch mit Exchange (15)

Frage von xbast1x zum Thema Windows Server ...

DSL, VDSL
DSL-Signal bewerten (14)

Frage von SarekHL zum Thema DSL, VDSL ...