Attribute VB_Name = "modRomeinsArabisch" Function RomanToArabic(sRoman As String) As String ' ______________________________________________________________________________ ' | | ' | Wim Gielis | ' | http://www.wimgielis.be | ' | Custom function to convert numbers in Roman notation | ' | to Arabic counterparts | ' | 12/01/07 | ' |______________________________________________________________________________| Dim iFirstLetterArabic As Integer Dim iSecondLetterArabic As Integer Dim i As Integer Application.Volatile sRoman = UCase(Trim(sRoman)) If IsNumeric(sRoman) Then RomanToArabic = "Please enter a roman number" Exit Function End If 'are there any "non-Roman" characters For i = 1 To Len(sRoman) Select Case Mid(sRoman, i, 1) Case "I", "V", "X", "L", "C", "D", "M" Case Else RomanToArabic = sRoman & " has ""non-Roman"" " & "characters in it" Exit Function End Select Next i Select Case Len(sRoman) Case 0: Exit Function Case 1: RomanToArabic = RomanToArabic + sBasicRoman(sRoman) Case Else: iFirstLetterArabic = sBasicRoman(Mid(sRoman, 1, 1)) iSecondLetterArabic = sBasicRoman(Mid(sRoman, 2, 1)) If iFirstLetterArabic < iSecondLetterArabic Then RomanToArabic = RomanToArabic + (iSecondLetterArabic - iFirstLetterArabic) sRoman = IIf(Len(sRoman) = 2, "", Mid(sRoman, 3)) RomanToArabic = RomanToArabic + RomanToArabic(sRoman) Else RomanToArabic = RomanToArabic + iFirstLetterArabic RomanToArabic = RomanToArabic + RomanToArabic(Mid(sRoman, 2)) End If End Select End Function Function sBasicRoman(sRoman As String) As Integer Select Case sRoman Case "I": sBasicRoman = 1 Case "V": sBasicRoman = 5 Case "X": sBasicRoman = 10 Case "L": sBasicRoman = 50 Case "C": sBasicRoman = 100 Case "D": sBasicRoman = 500 Case "M": sBasicRoman = 1000 End Select End Function