Function SpellNumberToEnglish(ByVal pNumber)

'Update by Extendoffice

Dim Dollars, Cents

arr = Array("", "", " Thousand ", " Million ", " Billion ", " Trillion ")

pNumber = Trim(Str(pNumber))

xDecimal = InStr(pNumber, ".")

If xDecimal > 0 Then

Cents = GetTens(Left(Mid(pNumber, xDecimal + 1) & "00", 2))

pNumber = Trim(Left(pNumber, xDecimal - 1))

End If

xIndex = 1

Do While pNumber <> ""

xHundred = ""

xValue = Right(pNumber, 3)

If Val(xValue) <> 0 Then

xValue = Right("000" & xValue, 3)

If Mid(xValue, 1, 1) <> "0" Then

xHundred = GetDigit(Mid(xValue, 1, 1)) & " Hundred "

End If

If Mid(xValue, 2, 1) <> "0" Then

xHundred = xHundred & GetTens(Mid(xValue, 2))

Else

xHundred = xHundred & GetDigit(Mid(xValue, 3))

End If

End If

If xHundred <> "" Then

Dollars = xHundred & arr(xIndex) & Dollars

End If

If Len(pNumber) > 3 Then

pNumber = Left(pNumber, Len(pNumber) - 3)

Else
 pNumber = ""

End If

xIndex = xIndex + 1

Loop

Select Case Dollars

Case ""

Dollars = "No Dollars"

Case "One"

Dollars = "One Dollar"

Case Else

Dollars = Dollars & " Dollars"

End Select

Select Case Cents

Case ""

Cents = " and No Cents"

Case "One"

Cents = " and One Cent"

Case Else

Cents = " and " & Cents & " Cents"

End Select

SpellNumberToEnglish = Dollars & Cents

End Function

Function GetTens(pTens)

Dim Result As String

Result = ""

If Val(Left(pTens, 1)) = 1 Then

Select Case Val(pTens)

Case 10: Result = "Ten"

Case 11: Result = "Eleven"

Case 12: Result = "Twelve"

Case 13: Result = "Thirteen"

Case 15: Result = "Fifteen"

Case 16: Result = "Sixteen"

Case 17: Result = "Seventeen"

Case 18: Result = "Eighteen"

Case 19: Result = "Nineteen"

Case Else

End Select

Else

Select Case Val(Left(pTens, 1))

Case 2: Result = "Twenty "

Case 3: Result = "Thirty "

Case 4: Result = "Forty "

Case 5: Result = "Fifty "

Case 6: Result = "Sixty "

Case 7: Result = "Seventy "

Case 8: Result = "Eighty "

Case 9: Result = "Ninety "

Case Else

End Select

Result = Result & GetDigit(Right(pTens, 1))

End If

GetTens = Result

End Function

Function GetDigit(pDigit)

Select Case Val(pDigit)

Case 1: GetDigit = "One"

Case 2: GetDigit = "Two"

Case 3: GetDigit = "Three"

Case 4: GetDigit = "Four"

Case 5: GetDigit = "Five"

Case 7: GetDigit = "Seven"

Case 8: GetDigit = "Eight"

Case 9: GetDigit = "Nine"

Case Else: GetDigit = ""

End Select

End Function
Function NumberstoWords(ByVal MyNumber)

'Update by Extendoffice

Dim xStr As String

Dim xFNum As Integer

Dim xStrPoint

Dim xStrNumber

Dim xPoint As String

Dim xNumber As String

Dim xP() As Variant

Dim xDP

Dim xCnt As Integer

Dim xResult, xT As String

Dim xLen As Integer

On Error Resume Next

xP = Array("", "Thousand ", "Million ", "Billion ", "Trillion ", " ", " ", " ", " ")

xNumber = Trim(Str(MyNumber))

xDP = InStr(xNumber, ".")

xPoint = ""

xStrNumber = ""

If xDP > 0 Then

xPoint = " point "

xStr = Mid(xNumber, xDP + 1)

xStrPoint = Left(xStr, Len(xNumber) - xDP)

For xFNum = 1 To Len(xStrPoint)

xStr = Mid(xStrPoint, xFNum, 1)

xPoint = xPoint & GetDigits(xStr) & " "

Next xFNum

xNumber = Trim(Left(xNumber, xDP - 1))

End If

xCnt = 0
xResult = ""

xT = ""

xLen = 0

xLen = Int(Len(Str(xNumber)) / 3)

If (Len(Str(xNumber)) Mod 3) = 0 Then xLen = xLen - 1

Do While xNumber <> ""

If xLen = xCnt Then

xT = GetHundredsDigits(Right(xNumber, 3), False)

Else

If xCnt = 0 Then

xT = GetHundredsDigits(Right(xNumber, 3), True)

Else

xT = GetHundredsDigits(Right(xNumber, 3), False)

End If

End If

If xT <> "" Then

xResult = xT & xP(xCnt) & xResult

End If

If Len(xNumber) > 3 Then

xNumber = Left(xNumber, Len(xNumber) - 3)

Else

xNumber = ""

End If

xCnt = xCnt + 1

Loop

xResult = xResult & xPoint

NumberstoWords = xResult

End Function

Function GetHundredsDigits(xHDgt, xB As Boolean)

Dim xRStr As String

Dim xStrNum As String

Dim xI As Integer

Dim xBB As Boolean

xStrNum = xHDgt

xRStr = ""

On Error Resume Next

xBB = True

If Val(xStrNum) = 0 Then Exit Function

xStrNum = Right("000" & xStrNum, 3)

xStr = Mid(xStrNum, 1, 1)

If xStr <> "0" Then

xRStr = GetDigits(Mid(xStrNum, 1, 1)) & "Hundred "

Else

If xB Then

xRStr = "and "

xBB = False

Else

xRStr = " "

xBB = False

End If

End If

If Mid(xStrNum, 2, 2) <> "00" Then

xRStr = xRStr & GetTenDigits(Mid(xStrNum, 2, 2), xBB)

End If

GetHundredsDigits = xRStr

End Function

Function GetTenDigits(xTDgt, xB As Boolean)

Dim xStr As String

Dim xI As Integer

Dim xArr_1() As Variant

Dim xArr_2() As Variant

xArr_1 = Array("Ten ", "Eleven ", "Twelve ", "Thirteen ", "Fourteen ", "Fifteen ", "Sixteen ",
"Seventeen ", "Eighteen ", "Nineteen ")

xArr_2 = Array("", "", "Twenty ", "Thirty ", "Forty ", "Fifty ", "Sixty ", "Seventy ", "Eighty ", "Ninety ")

xStr = ""

xT = True

On Error Resume Next

If Val(Left(xTDgt, 1)) = 1 Then

xI = Val(Right(xTDgt, 1))

If xB Then xStr = "and "

xStr = xStr & xArr_1(xI)

Else

xI = Val(Left(xTDgt, 1))

If Val(Left(xTDgt, 1)) > 1 Then

If xB Then xStr = "and "

xStr = xStr & xArr_2(Val(Left(xTDgt, 1)))

xT = False

End If

If xStr = "" Then

If xB Then

xStr = "and "

End If

End If

If Right(xTDgt, 1) <> "0" Then

xStr = xStr & GetDigits(Right(xTDgt, 1))

End If

End If

GetTenDigits = xStr

End Function

Function GetDigits(xDgt)

Dim xStr As String

xArr_1 = Array("Zero ", "One ", "Two ", "Three ", "Four ", "Five ", "Six ", "Seven ", "Eight ", "Nine ")

xStr = ""

On Error Resume Next

xStr = xArr_1(Val(xDgt))

GetDigits = xStr

End Function