Помогите пожалуйста!!!!!!!

[RRAFFF]

В VB не секу, а мне дали задание для курсовой - написать прогу, которая переводила бы все числа больше 1000 из арабских в такие же только римские! Помогите чем можете! Пожалуйста!

[Zer]

В смысле? Напремер 11 в XI ??? Напиши какое число в арабском соответствует числу в римском...

[A.A.Z.]

1 - I
5 - V
10 - X
50 - L
100 - C
500 - D
1000 - M

[alibek]

Есть еще 5000 и 10000. Только символов таких нет ни в кириллице, ни в латиннице. 10000 похожа на кириллическую "Ф", 5000 на такую же, только без левой "дуги".

[A.A.Z.]

Код: Выделить всё

Function ToRoman$(X&)
Dim S$
S = String(Int(X / 1000), "M")
X = X - (Int(X / 1000) * 1000)
If X >= 900 Then
S = S & "CM"
ElseIf X >= 500 And X < 900 Then
S = S & "D" & String(Int((X - 500) / 100), "C")
ElseIf X >= 400 And X < 500 Then
S = S & "CD"
Else
S = S & String(Int(X / 100), "C")
End If
X = X - (Int(X / 100) * 100)
If X >= 90 Then
S = S & "XC"
ElseIf X >= 50 And X < 90 Then
S = S & "L" & String(Int((X - 50) / 10), "X")
ElseIf X >= 40 And X < 50 Then
S = S & "XL"
Else
S = S & String(Int(X / 10), "X")
End If
X = X - (Int(X / 10) * 10)
If X >= 9 Then
S = S & "IX"
ElseIf X >= 5 And X < 9 Then
S = S & "V" & String(Int((X - 5) / 1), "I")
ElseIf X >= 4 And X < 5 Then
S = S & "IV"
Else
S = S & String(Int(X / 1), "I")
End If
ToRoman = S
End Function

Function ToArabic&(Roman$)
Dim Conv(7), A&, State&, Length&, I&, sidx&, RomNumber&, Comp1$, Comp2$
Conv(0) = "I,1"
Conv(1) = "V,5"
Conv(2) = "X,10"
Conv(3) = "L,50"
Conv(4) = "C,100"
Conv(5) = "D,500"
Conv(6) = "M,1000"
Conv(7) = "0,0"
Length = Len(Roman)
State = 0
Do While Length >= 0
I = 0
sidx = Length
RomNumber = CInt(Mid(Conv(I), InStr(1, Conv(I), ",") + 1, Len(Conv(I)) - InStr(1, Conv(I), ",")))
Do While RomNumber > 0
Comp1 = (Right(Left(Roman, sidx), 1))
Comp2 = Left(Conv(I), 1)
If (LCase(Comp1)) = CStr(LCase(Comp2)) Then
If State > RomNumber Then
A = A - RomNumber
Else
A = A + RomNumber
State = RomNumber
End If
End If
I = I + 1
If I = 8 Then GoTo ending:
RomNumber = CInt(Mid(Conv(I), InStr(1, Conv(I), ",") + 1, Len(Conv(I)) - InStr(1, Conv(I), ",")))
Loop
Length = Length - 1
Loop
ending:
ToArabic = A
End Function

Без учета добавления alibek'а. Использование - MsgBox ToRoman(1234) - в римские, MsgBox ToArabic("MCCXXXIV")

[alibek]

Знакомый код :)
Он не учитывает возможности "неправильного" написания, например LIIX (58), XIIIV (12).

[skiperski]

Как здесь уже правильно подметили, римские цифры обозначаются следующими буквами
'M - 1000
'D - 500
'C - 100
'L - 50
'X - 10
'V - 5
'I - 1

Алгоритм преобразования римских в арабские прост и однозначен. Обратное же преобразование - неоднозначно. Например, число 99 можно представить как XCIX и IC. Число 999 - CMXCIX и IM. Будем исходить из того, что в римской нотации числа записаны правильно, и перед символом большим по значению может стоять только один меньший по значению символ. Если комбинация символов соответствует уже зарезервированному символу, то используем последний. (Например, число 50 может быть выражено как LC или просто как L, используем L.) Т.е. числа пишем "правильно".

Код: Выделить всё

Option Explicit

Public Function Arabic2Rom(ByVal Value As Long) As String
   
    Dim i&, j&, n&
    Dim arab As Variant
    Dim roms As Variant
   
    arab = Split("1000 999 995 990 950 900 500 499 495 490 450 400 100 99 95 90 50 49 45 40 10 9 5 4 1")
    roms = Split("M IM VM XM LM CM D ID VD XD LD CD C IC VC XC L IL VL XL X IX V IV I")
   
    For i = 0 To UBound(arab)
        n = Value \ arab(i)
        Value = Value Mod arab(i)
        For j = 1 To n
            Arabic2Rom = Arabic2Rom & roms(i)
        Next
    Next
   
End Function

[skiperski]

Обратное преобразование однозначно даже с учётом "неправильной" записи.

Код: Выделить всё

Option Explicit

Public Function Rom2Arabic(ByVal Value As String) As Long
   
    Dim i&, n&, prev&, ch$, sign%
    Dim arab As Variant
   
    arab = Split("1000 500 100 50 10 5 1")
   
    For i = Len(Value) To 1 Step -1
        ch = UCase$(Mid$(Value, i, 1))
        If (n) Then prev = arab(n - 1)
        n = InStr(1, "MDCLXVI", ch)
        If (n) Then
            If (arab(n - 1) < prev) Then
                sign = -1
            ElseIf (arab(n - 1) > prev) Then
                sign = 1
            End If
            Rom2Arabic = Rom2Arabic + sign * arab(n - 1)
        End If
    Next
   
End Function

[RRAFFF]

Спасибо огромное! Только я еще раз повторюсь - это относится только к числам больше 1000

[A.A.Z.]

А, только? Тогда

Код: Выделить всё

Function ToRoman$(X&)
Dim S$
If X < 1000 Then Exit Function
S = String(Int(X / 1000), "M")
X = X - (Int(X / 1000) * 1000)
If X >= 900 Then
S = S & "CM"
ElseIf X >= 500 And X < 900 Then
S = S & "D" & String(Int((X - 500) / 100), "C")
ElseIf X >= 400 And X < 500 Then
S = S & "CD"
Else
S = S & String(Int(X / 100), "C")
End If
X = X - (Int(X / 100) * 100)
If X >= 90 Then
S = S & "XC"
ElseIf X >= 50 And X < 90 Then
S = S & "L" & String(Int((X - 50) / 10), "X")
ElseIf X >= 40 And X < 50 Then
S = S & "XL"
Else
S = S & String(Int(X / 10), "X")
End If
X = X - (Int(X / 10) * 10)
If X >= 9 Then
S = S & "IX"
ElseIf X >= 5 And X < 9 Then
S = S & "V" & String(Int((X - 5) / 1), "I")
ElseIf X >= 4 And X < 5 Then
S = S & "IV"
Else
S = S & String(Int(X / 1), "I")
End If
ToRoman = S
End Function

[RRAFFF]

Спасибо ОГРОМНЕЙШЕЕ!!! Выручили!javascript:emoticon(':D')
Very Happy