Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Const LB_SETTABSTOPS As Long = &H192
Private Sub Form_Load()
ReDim TabArray(0 To 1) As Long
TabArray(0) = 41
TabArray(1) = 103
'set list tabstops
Call SendMessage(List1.hwnd, LB_SETTABSTOPS, 0&, ByVal 0&)
Call SendMessage(List1.hwnd, LB_SETTABSTOPS, 2&, TabArray(0))
Randomize Time
Command1.Caption = "Convert Values"
End Sub
Private Sub Command1_Click()
Dim vArabic As Long
Dim sRoman As String
Dim vArabicBack As Long
List1.Clear
'create 20 random Arabic and Roman values
Do
'create a random number
vArabic = Int(Rnd(1) * 2002) + 1
'create Roman Numeral from the value
sRoman = NumberToRoman(vArabic)
'recreate Arabic value from the Roman
vArabicBack = RomanToNumber(sRoman)
'display the three in the list
List1.AddItem vArabic & vbTab & _
sRoman & vbTab & _
vArabicBack
Loop Until List1.ListCount = 20
End Sub
Private Function NumberToRoman(nArabicValue As Long) As String
Dim nThousands As Long
Dim nFiveHundreds As Long
Dim nHundreds As Long
Dim nFifties As Long
Dim nTens As Long
Dim nFives As Long
Dim nOnes As Long
Dim tmp As String
'take the value passed and split it out
'to values representing the number of
'ones, tens, hundreds, etc
nOnes = nArabicValue
nThousands = nOnes \ 1000
nOnes = nOnes - nThousands * 1000
nFiveHundreds = nOnes \ 500
nOnes = nOnes - nFiveHundreds * 500
nHundreds = nOnes \ 100
nOnes = nOnes - nHundreds * 100
nFifties = nOnes \ 50
nOnes = nOnes - nFifties * 50
nTens = nOnes \ 10
nOnes = nOnes - nTens * 10
nFives = nOnes \ 5
nOnes = nOnes - nFives * 5
'using VB's String function, create
'a series of strings representing
'the number of each respective denomination
tmp = String(nThousands, "M")
'handle those cases where the denominator
'value is on either side of a roman numeral
If nHundreds = 4 Then
If nFiveHundreds = 1 Then
tmp = tmp & "CM"
Else
tmp = tmp & "CD"
End If
Else
'not a 4, so create the string
tmp = tmp & String(nFiveHundreds, "D") & String(nHundreds, "C")
End If
If nTens = 4 Then
If nFifties = 1 Then
tmp = tmp & "XC"
Else
tmp = tmp & "XL"
End If
Else
tmp = tmp & String(nFifties, "L") & String(nTens, "X")
End If
If nOnes = 4 Then
If nFives = 1 Then
tmp = tmp & "IX"
Else
tmp = tmp & "IV"
End If
Else
tmp = tmp & String(nFives, "V") & String(nOnes, "I")
End If
NumberToRoman = tmp
End Function
Private Function RomanToNumber(ByVal strRoman As String) As Long
Dim cnt As Long
Dim strLen As Long
Dim nChar As Long
Dim nNextChar As Long
Dim nNextChar2 As Long
Dim tmpVal As Long
'convert to lower case, and check for
'any invalid strings
strRoman = LCase(strRoman)
If InStr(strRoman, "iiii") Or _
InStr(strRoman, "xxxx") Or _
InStr(strRoman, "cccc") Or _
InStr(strRoman, "vv") Or _
InStr(strRoman, "ll") Or _
InStr(strRoman, "dd") Then
'something's fishy, so bail
RomanToNumber = -1
Exit Function
End If
'for each character in the roman numeral,
'tokenize the character by changing it
'to a numeric representation. For example,
'the Roman Numeral 1995 (MCMXCV) is
'represented by the tokenized string
'"757352"
strLen = Len(strRoman)
For cnt = 1 To strLen
Select Case Mid$(strRoman, cnt, 1)
Case "i": Mid$(strRoman, cnt, 1) = 1
Case "v": Mid$(strRoman, cnt, 1) = 2
Case "x": Mid$(strRoman, cnt, 1) = 3
Case "l": Mid$(strRoman, cnt, 1) = 4
Case "c": Mid$(strRoman, cnt, 1) = 5
Case "d": Mid$(strRoman, cnt, 1) = 6
Case "m": Mid$(strRoman, cnt, 1) = 7
End Select
Next
For cnt = 1 To strLen
'obtain the token for the current character
nChar = CInt(Mid$(strRoman, cnt, 1))
'in order to properly sum the tokens,
'the next two tokens are also needed
If cnt < strLen Then
nNextChar = CInt(Mid$(strRoman, cnt + 1, 1))
If cnt < strLen - 1 Then
nNextChar2 = CInt(Mid$(strRoman, cnt + 2, 1))
Else
nNextChar2 = 0
End If
'based on the retrieved token value,
'calculate a temp value based on it
'and the subsequent tokens
Select Case nChar
Case 7: tmpVal = GetTmpVal2(nChar, _
nNextChar, _
nNextChar2, _
tmpVal, _
cnt, 1000)
Case 6: tmpVal = GetTmpVal2(nChar, _
nNextChar, _
nNextChar2, _
tmpVal, _
cnt, 500)
Case 5: tmpVal = GetTmpVal2(nChar, _
nNextChar, _
nNextChar2, _
tmpVal, _
cnt, 100)
Case 4: tmpVal = GetTmpVal2(nChar, _
nNextChar, _
nNextChar2, _
tmpVal, _
cnt, 50)
Case 3: tmpVal = GetTmpVal2(nChar, _
nNextChar, _
nNextChar2, _
tmpVal, _
cnt, 10)
Case 2: tmpVal = GetTmpVal2(nChar, _
nNextChar, _
nNextChar2, _
tmpVal, _
cnt, 5)
Case 1: tmpVal = GetTmpVal2(nChar, _
nNextChar, _
nNextChar2, _
tmpVal, _
cnt, 1)
End Select
Else
tmpVal = tmpVal + ConvertValue(nChar)
End If
If tmpVal = -1 Then Exit For
Next
RomanToNumber = tmpVal
End Function
Private Function GetTmpVal2(nChar As Long, _
nNextChar As Long, _
nNextChar1 As Long, _
tmpVal As Long, _
cnt As Long, _
intValue As Long) As Long
If nNextChar > nChar Then
If ((nNextChar - nChar = 1 And _
(nChar <> 2 And nChar <> 6)) _
Or (nNextChar - nChar = 2 And _
(nNextChar <> 4 And nNextChar <> 6))) _
And nNextChar1 < nNextChar _
And nNextChar1 <> nChar Then
tmpVal = tmpVal + ConvertValue(nNextChar) - intValue
cnt = cnt + 1
Else
tmpVal = -1
End If
Else
tmpVal = tmpVal + intValue
End If
GetTmpVal2 = tmpVal
End Function
Private Function ConvertValue(ByVal nVal As Long) As Long
Select Case nVal
Case 7: ConvertValue = 1000
Case 6: ConvertValue = 500
Case 5: ConvertValue = 100
Case 4: ConvertValue = 50
Case 3: ConvertValue = 10
Case 2: ConvertValue = 5
Case 1: ConvertValue = 1
End Select
End Function
Hope you understand it
2006-08-18 00:50:31
·
answer #3
·
answered by Joe_Young 6
·
0⤊
1⤋