Option Compare Database
Option Explicit
Option Base 0
'Author: © Copyright 2001 Pacific Database Pty Limited
' Graham R Seach (e-mail address removed)
' Phone: +61 2 9872 9594 Fax: +61 2 9872 9593
'
' You may freely use and distribute this code
' with any applications you may develop, on the
' condition that the copyright notice remains
' unchanged, and intact as part of the code. You
' may not sell or publish this code in any form
' without the express written permission of the
' copyright holder.
'
'Description: This function converts numbers to
' their textual representation, including real, verbatim
' currency, miles and Roman.
'
'Inputs: dblNum: The number to be converted.
' intType: is the enum value representing the
' number type to be converted to.
' intCapType: is the enum value representing the
' output capitalisation required.
'
'Outputs: The number's textual representation.
Public Enum ConvType
ConvTypeReal = 1
ConvTypeVerbatim = 2
ConvTypeCurrency = 3
ConvTypeKm = 4
ConvTypeMi = 5
ConvTypeRoman = 6
End Enum
Public Enum CapType
CapUpperCase = 1
CapLowerCase = 2
CapProperCase = 3
CapProperCase_MinorLC = 4
End Enum
Public Function Num2Text(dblNum As Double, intType As ConvType, _
Optional intCapType As CapType = 1) As String
Dim strNum As String
Dim strFrac As String
Dim strTemp As String
Dim strReturn As String
Dim iCtr As Integer
Dim iPart As Integer
iPart = 1
strFrac = ""
strNum = CStr(dblNum)
'Check for fractional part
iCtr = InStr(1, strNum, ".")
If iCtr <> 0 Then
If intType = 6 Then
'If converting to Roman Numerals, can't have fractions
Num2Text = CStr(dblNum)
Exit Function
End If
If (intType = ConvTypeCurrency) Then
If (Len(strNum) - iCtr) = 1 Then strNum = strNum & "0"
'strFrac = " " & ConvertReal(CDbl(Right(strNum, Len(strNum) -
iCtr)))
strFrac = ConvertReal(CDbl(Right(strNum, Len(strNum) - iCtr)))
Else
strFrac = ConvertVerbatim(CDbl(Right(strNum, Len(strNum) - iCtr)))
End If
strNum = Left(strNum, iCtr - 1)
End If
Select Case intType
Case 1, 3, 4, 5 '*** Convert into real numbers (1) or currency (3) ***
'Pad strNum to blocks of 3
Do While (Len(strNum) / 3) - Int(Len(strNum) / 3) <> 0
strNum = "0" & strNum
Loop
For iCtr = Len(strNum) - 2 To 1 Step -3
strTemp = ConvertReal(Mid(strNum, iCtr, 3))
strTemp = strTemp & AddNouns(strTemp, iPart, _
(intType = ConvTypeCurrency) And (iPart = 1))
strReturn = strTemp & strReturn
iPart = iPart + 1
Next iCtr
Case 2 '*** Convert the individual numbers verbatim ***
strReturn = ConvertVerbatim(CDbl(strNum))
Case 6 '*** Convert to Roman Numerals ***
Num2Text = Num2Roman(CLng(dblNum))
GoTo SetCase
End Select
Select Case intType
Case ConvTypeCurrency
If (strReturn <> "") Then strReturn = strReturn & " dollars "
If (strFrac <> "") Then strFrac = strFrac & " cents"
Case ConvTypeKm
strFrac = IIf(strFrac <> "", " point " & strFrac, "") & "
kilometers"
Case ConvTypeMi
strFrac = IIf(strFrac <> "", " point " & strFrac, "") & " miles"
Case Else: If (strFrac <> "") Then strFrac = " point " & strFrac
End Select
Num2Text = Trim(strReturn & strFrac)
If Left(Trim(Num2Text), 3) = "and" Then Num2Text =
Trim(Mid(Trim(Num2Text), 4))
SetCase:
Select Case intCapType
Case CapUpperCase 'Uppercase
strTemp = UCase(Num2Text)
Case CapLowerCase 'Lowercase
strTemp = LCase(Num2Text)
Case CapProperCase 'Propercase
strTemp = StrConv(Num2Text, vbProperCase)
Case CapProperCase_MinorLC 'Propercase with Lowercase 'and'
strTemp = Replace(StrConv(Num2Text, vbProperCase), "And", "and")
End Select
'Remove any double-spaces
Num2Text = Replace(strTemp, " ", " ")
End Function
Private Function ConvertVerbatim(dblNum As Double) As String
Dim iCtr As Integer
Dim iMaxlen As Integer
Dim strNum As String
strNum = CStr(dblNum)
ConvertVerbatim = ""
iMaxlen = Len(strNum)
For iCtr = 1 To iMaxlen
Select Case Asc(Mid(strNum, iCtr, 1)) - 48
Case 0: ConvertVerbatim = ConvertVerbatim & "zero"
Case 1: ConvertVerbatim = ConvertVerbatim & "one"
Case 2: ConvertVerbatim = ConvertVerbatim & "two"
Case 3: ConvertVerbatim = ConvertVerbatim & "three"
Case 4: ConvertVerbatim = ConvertVerbatim & "four"
Case 5: ConvertVerbatim = ConvertVerbatim & "five"
Case 6: ConvertVerbatim = ConvertVerbatim & "six"
Case 7: ConvertVerbatim = ConvertVerbatim & "seven"
Case 8: ConvertVerbatim = ConvertVerbatim & "eight"
Case 9: ConvertVerbatim = ConvertVerbatim & "nine"
End Select
If iCtr < iMaxlen Then ConvertVerbatim = ConvertVerbatim & " "
Next iCtr
End Function
Private Function ConvertReal(dblNum As Double) As String
Dim strNum As String
Dim iCtr As Integer
Dim strTemp As String
Dim sN As String
strNum = CStr(dblNum)
'Pad strNum to blocks of 3
Do While (Len(strNum) / 3) - Int(Len(strNum) / 3) <> 0
strNum = "0" & strNum
Loop
If Mid(strNum, 1, 1) <> 0 Then strTemp = ConvertVerbatim(Left(strNum,
1)) & " hundred"
If Mid(strNum, 2, 1) <> 0 Or Mid(strNum, 3, 1) <> 0 Then strTemp =
strTemp & " and"
sN = Mid(strNum, 2, 2)
Select Case Asc(Mid(strNum, 2, 1)) - 48
Case 0:
Case 1
strTemp = strTemp & Switch(sN = "10", " ten", sN = "11", "
eleven", _
sN = "12", " twelve", sN = "13", " thirteen", sN = "14",
" fourteen", _
sN = "15", " fifteen", sN = "16", " sixteen", sN = "17",
" seventeen", _
sN = "18", " eighteen", sN = "19", " nineteen")
Case 2: strTemp = strTemp & " twenty"
Case 3: strTemp = strTemp & " thirty"
Case 4: strTemp = strTemp & " forty"
Case 5: strTemp = strTemp & " fifty"
Case 6: strTemp = strTemp & " sixty"
Case 7: strTemp = strTemp & " seventy"
Case 8: strTemp = strTemp & " eighty"
Case 9: strTemp = strTemp & " ninety"
End Select
If Mid(strNum, 2, 1) <> 1 Then strTemp = strTemp & " " &
ConvertVerbatim(Mid(strNum, 3, 1))
If Right(strTemp, 4) = "zero" Then strTemp = Left(strTemp, Len(strTemp)
- 5)
ConvertReal = Trim(strTemp)
End Function
Private Function Num2Roman(ByVal lngNum As Long) As String
Const Digits = "IVXLCDM"
Dim ctr As Integer, intDigit As Integer, strTmp As String
ctr = 1
strTmp = ""
Do While lngNum > 0
intDigit = lngNum Mod 10
lngNum = lngNum \ 10
Select Case intDigit
Case 1: strTmp = Mid(Digits, ctr, 1) & strTmp
Case 2: strTmp = Mid(Digits, ctr, 1) & Mid(Digits, ctr, 1) &
strTmp
Case 3: strTmp = Mid(Digits, ctr, 1) & Mid(Digits, ctr, 1) & _
Mid(Digits, ctr, 1) & strTmp
Case 4: strTmp = Mid(Digits, ctr, 2) & strTmp
Case 5: strTmp = Mid(Digits, ctr + 1, 1) & strTmp
Case 6: strTmp = Mid(Digits, ctr + 1, 1) & Mid(Digits, ctr, 1) &
strTmp
Case 7: strTmp = Mid(Digits, ctr + 1, 1) & Mid(Digits, ctr, 1) & _
Mid(Digits, ctr, 1) & strTmp
Case 8: strTmp = Mid(Digits, ctr + 1, 1) & Mid(Digits, ctr, 1) & _
Mid(Digits, ctr, 1) & Mid(Digits, ctr, 1) & strTmp
Case 9: strTmp = Mid(Digits, ctr, 1) & Mid(Digits, ctr + 2, 1) &
strTmp
End Select
ctr = ctr + 2
Loop
Num2Roman = strTmp
End Function
Private Function AddNouns(strNum As String, ByVal intPart As Integer, _
booCurrency As Boolean) As String
If Len(strNum) > 0 Then
Select Case intPart
'Case 1: If (booCurrency = True) Then AddNouns = " dollars"
Case 2: AddNouns = " thousand "
Case 3: AddNouns = " million "
Case 4: AddNouns = " billion "
Case 5: AddNouns = " trillion "
Case 6: AddNouns = " quadrillion "
Case 7: AddNouns = " quintillion "
Case 8: AddNouns = " sextillion "
Case 9: AddNouns = " septillion "
Case 10: AddNouns = " octillion"
End Select
Else
AddNouns = ""
End If
End Function
