How to Get the String Representation of a Numerice Value (Check Writer)

Option Compare Database
Option Explicit             'Require explicit variable declaration

    'Michael Red.   9/7/01.  Provide either "Check Writer" or "Technical"
    'Translation of numerivc values to Words / String

    Dim intNum(20) As String
    Dim strGrp(5) As String
    Dim NumTens(10) As String
    Dim blnNumWdsInit As Boolean
Public Function basNum2Word(ByVal ValIn As Double, _
                           Optional ChkStr As Boolean = True) As String

    Dim Idx As Integer
    Dim Jdx As Integer
    Dim Kdx As Integer
    Dim DecPl As Integer
    Dim DecPt As Single
    Dim strNum As String
    Dim str3Num As String
    Dim str3Words As String
    Dim strTemp As String
    Dim strEngl As String
    Dim NumAry As Variant

    strEngl = ""    'Initialize

    If (blnNumWdsInit <> True) Then
        blnNumWdsInit = basInitNumWords
    End If

    strNum = CStr(ValIn)        'Convert value to a string.
    
    NumAry = basSplit(strNum, ".")    'Seperate the "Whole" Number from the decimal
    
    strEngl = ""            'Assure Words are empty
    Kdx = 1                 'Set up Tag for Group (Triad)
    Idx = Len(NumAry(0))    'Initalize Number String Index
    Do While Idx > 0
        str3Num = "000"     'Initalize Triad
        Jdx = 3
        Do While Jdx > 0
            If (Idx <= 0) Then
                Exit Do
            End If
            Mid(str3Num, Jdx, 1) = Mid(NumAry(0), Idx, 1)
            Jdx = Jdx - 1
            Idx = Idx - 1
        Loop
        'Process the Triad
        str3Words = basNumStr2Triad(str3Num)
        strTemp = strEngl
        strEngl = str3Words & " " & strGrp(Kdx) & " " & strTemp
        Kdx = Kdx + 1
    Loop

    strEngl = Trim(strEngl)

    If (ChkStr = True) Then
        'Do the Currency Round off
        If (Len(NumAry(1)) <> 0) Then
            DecPt = Round(CSng("." & NumAry(1)), 2) * 100
         Else
            DecPt = "00"
        End If
        strEngl = strEngl & " Dollars AND " & Trim(CStr(DecPt)) & " Cents"
     Else
        'Do the entire decimal fraction in Words
        If (Len(NumAry(1) <> 0)) Then
                strEngl = strEngl & " Point "
                strEngl = strEngl & basDecNum2Str(NumAry(1))
        End If
    End If

    basNum2Word = Trim(strEngl)

End Function
Public Function basDecNum2Str(DecAry As Variant) As String

    Dim Idx As Integer
    Dim TmpStr As String

    If (blnNumWdsInit <> True) Then
        blnNumWdsInit = basInitNumWords
    End If

    'Just uses the Digits
    For Idx = 1 To Len(DecAry)
        TmpStr = TmpStr & intNum(CInt(Mid(DecAry, Idx, 1))) & Space(1)
    Next Idx

    basDecNum2Str = Trim(TmpStr)

End Function
Public Function basNumStr2Triad(NumAray As String) As String

    Dim Idx As Integer
    Dim Jdx As Integer
    Dim MyVal As Integer
    Dim Triad(3) As String
    Dim MyStr As String

    If (blnNumWdsInit <> True) Then
        blnNumWdsInit = basInitNumWords
    End If

    Idx = Len(NumAray)
    Do While Idx >= 1

        Jdx = 3
        'Clear Triad
        Do While Jdx >= 1
            Triad(Jdx) = 0
            Jdx = Jdx - 1
        Loop

        Jdx = 3
        Do While Jdx >= 1
            'Fill Triad
            Triad(Jdx) = Mid(NumAray, Idx, 1)
            Jdx = Jdx - 1
            Idx = Idx - 1
        Loop

        'Process Triad
        If (Triad(1) <> 0) Then
            'Have a "Hundered"s
            MyStr = intNum(Val(Triad(1))) & " " & "Hundred"
        End If

        If (Val(Trim(Triad(2))) <= 1) Then
         MyVal = Val((Trim(Triad(2))) & (Trim(Triad(3))))
            MyStr = MyStr & " " & intNum(MyVal)
         Else
            MyStr = MyStr & " " & NumTens(Val(Trim(Triad(2))))
            If (Val(Trim(Triad(3))) <> 0) Then
                MyStr = MyStr & " " & intNum(Val(Trim(Triad(3))))
            End If
        End If

        If (Triad(1) <> 0) Then
        End If

    Loop

    basNumStr2Triad = MyStr

End Function
Public Function basInitNumWords()

    intNum(0) = "Zero"
    intNum(1) = "One"
    intNum(2) = "Two"
    intNum(3) = "Three"
    intNum(4) = "Four"
    intNum(5) = "Five"
    intNum(6) = "Six"
    intNum(7) = "Seven"
    intNum(8) = "Eight"
    intNum(9) = "Nine"
    intNum(10) = "Ten"
    intNum(11) = "Eleven"
    intNum(12) = "Twelve"
    intNum(13) = "Thirteen"
    intNum(14) = "Fourteen"
    intNum(15) = "Fifteen"
    intNum(16) = "Sixteen"
    intNum(17) = "Seventeen"
    intNum(18) = "Eighteen"
    intNum(19) = "Nineteen"

    NumTens(0) = ""
    NumTens(1) = "Ten"
    NumTens(2) = "Twenty"
    NumTens(3) = "Thirty"
    NumTens(4) = "Forty"
    NumTens(5) = "Fifty"
    NumTens(6) = "Sixty"
    NumTens(7) = "Seventy"
    NumTens(8) = "Eighty"
    NumTens(9) = "Ninety"

    strGrp(0) = ""
    strGrp(1) = ""
    strGrp(2) = "Thousand"
    strGrp(3) = "Million"
    strGrp(4) = "Billion"
    strGrp(5) = "Trillion"

    basInitNumWords = True

End Function
Public Function basDecNum2Words(T1 As String)

    Dim intVal As String
    Dim NewVal As String
    Dim MyDecVal As String
    Dim DecCheck As Integer
    Dim strDec As String

    strDec = "  and "

    If InStr(T1, ".") > 0 Then
        intVal = Left(Val(Nz(T1)), InStr(T1, ".") - 1)
        DecCheck = 0
     Else
        intVal = Val(Nz(T1))
        DecCheck = 1
    End If

    NewVal = ""

Start:

    On Error Resume Next
    'Check for the teens in thousands place
    If Mid(intVal, Len(intVal) - 4, 2) <= 20 Then
        NewVal = NewVal & Switch(Mid(intVal, Len(intVal) - 4, 2) = "10", " Ten Thousand", _
        Mid(intVal, Len(intVal) - 4, 2) = "11", " Eleven Thousand", _
        Mid(intVal, Len(intVal) - 4, 2) = "12", " Twelve Thousand", _
        Mid(intVal, Len(intVal) - 4, 2) = "13", " Thirteen Thousand", _
        Mid(intVal, Len(intVal) - 4, 2) = "14", " Fourteen Thousand", _
        Mid(intVal, Len(intVal) - 4, 2) = "15", " Fifteen Thousand", _
        Mid(intVal, Len(intVal) - 4, 2) = "16", " Sixteen Thousand", _
        Mid(intVal, Len(intVal) - 4, 2) = "17", " Seventeen Thousand", _
        Mid(intVal, Len(intVal) - 4, 2) = "18", " Eighteen Thousand", _
        Mid(intVal, Len(intVal) - 4, 2) = "19", " Nineteen Thousand", _
        Mid(intVal, Len(intVal) - 4, 2) = "20", " Twenty Thousand")
     Else

        NewVal = NewVal & Choose(Mid(intVal, Len(intVal) - 4, 1), "", " Twenty", " Thirty", _
                        " Forty", " Fifty", " Sixty", " Seventy", _
                        " Eighty", " Ninety")
    End If

    If Mid(intVal, Len(intVal) - 4, 2) > 19 Then
        NewVal = NewVal & Choose(Mid(intVal, Len(intVal) - 3, 1), _
                        " One Thousand", " Two Thousand", _
                        " Three Thousand", " Four Thousand", _
                        " Five Thousand", _
                        " Six Thousand", " Seven Thousand", _
                        " Eight Thousand", " Nine Thousand")
    End If

    NewVal = NewVal & Choose(Mid(intVal, Len(intVal) - 2, 1), " One Hundred", " Two Hundred", _
                    " Three Hundred", " Four Hundred", " Five Hundred", _
                    " Six Hundred", " Seven Hundred", _
                    " Eight Hundred", " Nine Hundred")

    'Check for the teens
    'If Mid(intval, Len(intval) - 1) > 9 And _
    'Mid(intval, Len(intval) - 1) < 20 Then

    If Mid(intVal, Len(intVal) - 1, 1) = "1" Then
        NewVal = NewVal & Switch(Mid(intVal, Len(intVal) - 1) = "10", " Ten", _
        Mid(intVal, Len(intVal) - 1) = "11", " Eleven", _
        Mid(intVal, Len(intVal) - 1) = "12", " Twelve", _
        Mid(intVal, Len(intVal) - 1) = "13", " Thirteen", _
        Mid(intVal, Len(intVal) - 1) = "14", " Fourteen", _
        Mid(intVal, Len(intVal) - 1) = "15", " Fifteen", _
        Mid(intVal, Len(intVal) - 1) = "16", " Sixteen", _
        Mid(intVal, Len(intVal) - 1) = "17", " Seventeen", _
        Mid(intVal, Len(intVal) - 1) = "18", " Eighteen", _
        Mid(intVal, Len(intVal) - 1) = "19", " Nineteen")

     Else

        NewVal = NewVal & Choose(Mid(intVal, Len(intVal) - 1, 1), "", " Twenty", " Thirty", _
                        " Forty", " Fifty", " Sixty", " Seventy", _
                        " Eighty", " Ninety")
    End If
            
    If Mid(intVal, Len(intVal) - 1) > 19 Or _
        Mid(intVal, Len(intVal) - 1) < 10 Then
           
        If NewVal <> "" And right(NewVal, 1) <> "y" And right(NewVal, 4) <> "and " Then
            NewVal = NewVal & Choose(Mid(intVal, Len(intVal), 1), _
                     " and One", " and Two", _
                     " and Three", " and Four", " and Five", " and Six", _
                     " and Seven", " and Eight", " and Nine")
         Else
            NewVal = NewVal & Choose(Mid(intVal, Len(intVal), 1), " One", " Two", _
                        " Three", " Four", " Five", " Six", _
                        " Seven", " Eight", " Nine")
        End If
    End If
            
    DecCheck = DecCheck + 1
    If DecCheck < 2 Then
        intVal = Mid(Val(Nz(T1)), InStr(Val(Nz(T1)), ".") + 1)
        NewVal = NewVal & strDec
            Select Case Len(intVal)
                Case 1
                    MyDecVal = " Tenths"
                Case 2
                    MyDecVal = " One-Hundredths"
                Case 3
                    MyDecVal = "One-Thousandths"
                Case 4
                    MyDecVal = " Ten-Thousandths"
                Case 5
                    MyDecVal = "Hundred-Thousandths"
            End Select
                
        GoTo Start
    End If

    basDecNum2Words = NewVal & MyDecVal

End Function
Public Function basSplit(strIn As String, _
                         Optional DelimChar As String = " ") _
                         As Variant

'just give credit where credit is due


    'to return an array of the tokens (Words) in a dellimited list of values
    'the delimiter may be set by the user.  The default value for the dilimiter
    'is a single space.  The Delimiter may be set to any string, however only the
    'first character of the string is used.

    'Michael Red, 9/25/00 for the Duvall Group, Columbia, MD
    'Usage & Example

    'MyArray = basSplit("Me, Myself, I, Thee, Thou, Though, Go, This is a also a test", ",")
    'For xx = 0 To UBound(MyArray): Print xx, MyArray(xx): Next xx
    '0      Me
    '1       Myself
    '2       I
    '3       Thee
    '4       Thou
    '5       Though
    '6       Go
    '7       This is a also a test


    Dim Idx As Integer
    Dim Delim As Integer
    Dim PrevDelim As Integer
    Dim WdsDone As Boolean
    
    Dim WdAray() As String

    DelimChar = Left(DellimChar, 1)

    Idx = 0                         'Init WdAray Index
    PrevDelim = 0                   'Start w/ Previous position of Delimiter Before String
    ReDim WdAray(Idx)               'Initalize array of Words to single element

    While Not WdsDone
        Delim = InStr(PrevDelim + 1, strIn, DelimChar)
        If (Delim = 0) Then     'Can't find any more dellimiters.
            'Must be done.  Just add the remainder of the Input to this element of WdAray
            WdAray(Idx) = Right(strIn, Len(strIn) - (PrevDelim))
            WdsDone = True           'Tell'em were done here
         Else
            'Somewhere in the midst of all this, we jave found a "Real" word
            WdAray(Idx) = Mid(strIn, PrevDelim + 1, ((Delim - 1) - (PrevDelim - 1)) - 1)
            Idx = Idx + 1
            ReDim Preserve WdAray(Idx)
            PrevDelim = Delim
        End If
    Wend

    basSplit = WdAray

End Function