ローマ数字をアラビア語に変更する（Microsoft Word）

Sub ConvertRoman()

Dim wrdX     Dim wrd As String     Dim tstSW As Boolean     Dim J As Long

For Each wrdX In ActiveDocument.Words         wrd = UCase(Trim(wrdX))

If wrd = "" Or wrd = "I" Or wrd = vbCr Then             tstSW = False         Else             tstSW = True         End If         For J = 1 To Len(wrd)

If InStr("MDCLXVI",Mid(wrd, J, 1)) = 0 Then                 tstSW = False                 Exit For             End If         Next J

If tstSW Then             wrdX.Select             Selection.MoveLeft unit:=wdCharacter, _               Count:=Len(wrdX) - Len(wrd), _               Extend:=wdExtend             J = MsgBox("Convert " & wrd & " to Arabic", vbYesNoCancel)

If J = vbCancel Then Exit Sub             If J = vbYes Then Selection.TypeText Text:=RomanToArabic(wrd)

End If     Next wrdX End Sub

Function RomanToArabic(Rm As String) As String     Dim J As Long     Dim ab As Long     Dim cc As Long     Dim dd As Long

ab = 0     Rm = Trim(Rm)

J = 1     Do         cc = GetValue(Mid(Rm, J, 1))

dd = GetValue(Mid(Rm, J + 1, 1))

If cc < dd Then             ab = ab + dd - cc             J = J + 1         Else             ab = ab + cc         End If         J = J + 1     Loop Until J >= Len(Rm)

If J = Len(Rm) Then         ab = ab + GetValue(Mid(Rm, J, 1))

End If     RomanToArabic = Trim(Str(ab))

End Function

Function GetValue(ss As String) As Long     Dim Cde()

Dim Cvalue()

Dim J As Long

Cde = Array("M", "D", "C", "L", "X", "V", "I")

Cvalue = Array(1000, 500, 100, 50, 10, 5, 1)



For J = 0 To 6         If ss = Cde(J) Then             GetValue = Cvalue(J)

Exit Function         End If     Next J     GetValue = 999999 End Function