Funkciju koja radi isti posao našao sam u nekoj knjizi, meni je konkretno poslužila u wordu, ali radi u bilo kom programu koji podržava VBA.
Možda nekom zatreba.
Code:
Procedure : dhRoman
' Ulaz : Broj
' Pov. vred : String koji daje rimski broj
' Primer : Debug.Print dhRoman(1997); displays; "MCMXCVII",
' Debug.Print dhRoman(3999) displays "MMMCMXCIX".
' Opis : Converting a Number into Roman Numerals. If you're creating legal documents programmatically, or if your job involves copy-right notifications (well, it is somewhat difficult coming up with compelling scenarios for this one), you're likely to require the capability to convert integers into roman numerals. Although this need may not come up often, when it does, it's tricky enough that you'll want to avoid having to write the code yourself. The dhRoman function, in Listing, can accept an integer between 1 and 3999 (the Romans didn't have a concept of 0), and it returns the value converted into roman numerals. For example:
' Attempting to convert a number greater than 3999 or less than 1 will raise a runtime error in dhRoman.
' Convert Numbers to Roman Numerals
' How does dhRoman do its work? As you probably know,
' all numbers built in roman numerals between 1 and 3999
' consist of the seven digits I, V, X, L, C, D, and M.
' The I, X, C, and M digits represent 1, 10, 100, and 1000; V, L,
' and D represent 5, 50, and 500, respectively. The code loops
' through all the digits of your input value from right to left,
' using the Mod operator to strip them off one by one:
' Do While intValue > 0
' intDigit = intValue Mod 10
' intValue = intValue \ 10 ' (Code removed)
' intPos = intPos + 2Loop
' At each point in the loop, intDigit contains the
' right-most digit of the value, and intValue keeps
' getting smaller, one digit at a time. For example, the
' following table shows the values of the two variables
' while dhRoman tackles the value 1234:In addition,
' intPos indicates which array element to use in building
' the string as the code moves through the ones, tens, hundreds,
' and thousands places in the value.Based on the value in intDigit,
' the code uses a Select Case construct to choose the characters
' to prepend to the output string. (That's right-prepend.
' dhRoman constructs the output string from right to left,
' adding items to the left of the string as it works.) For example,
' for the value 1234, dhRoman finds the digit 4 when int-Pos is 0.
' The code says to usestrTemp = varDigits(intPos) &
' _ varDigits(intPos + 1) & strTempin this case. Because intPos is 0,
' the output is IV (varDigits(0) & varDigits(1)). If the 4 had been
' in the hundreds place (imagine you're converting 421 to roman numerals),
' then intPos woud be 2, the expression would say to use varDigits(4)
' & varDigits(5), and the output would be "CD" for this digit.
'---------------------------------------------------------------------------------------
Public Function dhRoman(ByVal intValue As Integer) As String
Dim varDigits As Variant
Dim lngPos As Integer
Dim intDigit As Integer
Dim strTemp As String
' Build up the array of roman digits
On Error GoTo dhRoman_Error
varDigits = Array("I", "V", "X", "L", "C", "D", "M")
lngPos = LBound(varDigits)
strTemp = ""
Do While intValue > 0
intDigit = intValue Mod 10
intValue = intValue \ 10
Select Case intDigit
Case 1
strTemp = varDigits(lngPos) & strTemp
Case 2
strTemp = varDigits(lngPos) & varDigits(lngPos) & strTemp
Case 3
strTemp = varDigits(lngPos) & varDigits(lngPos) & varDigits(lngPos) & strTemp
Case 4
strTemp = varDigits(lngPos) & varDigits(lngPos + 1) & strTemp
Case 5
strTemp = varDigits(lngPos + 1) & strTemp
Case 6
strTemp = varDigits(lngPos + 1) & varDigits(lngPos) & strTemp
Case 7
strTemp = varDigits(lngPos + 1) & varDigits(lngPos) & varDigits(lngPos) & strTemp
Case 8
strTemp = varDigits(lngPos + 1) & varDigits(lngPos) & varDigits(lngPos) & varDigits(lngPos) & strTemp
Case 9
strTemp = varDigits(lngPos) & varDigits(lngPos + 2) & strTemp
End Select
lngPos = lngPos + 2
Loop
dhRoman = strTemp
On Error GoTo 0
Exit Function
dhRoman_Exit:
Exit Function
dhRoman_Error:
MsgBox "Greška: " & Err.Number & vbCrLf & "Opis: " & Err.Description & vbCrLf & "U proceduti: dhRoman"
Resume dhRoman_Exit
End Function