Function ValorExtenso(pValor as number) as string
Dim sValor As String
Dim sInt As String
Dim sDec As String
Dim nI As Number
Dim sExt As String
Dim sNum As String

sValor = CStr(pValor)
sValor = Replace( sValor, ".", "")

' Matriz de nomes
Dim mUni(10) As String
Dim mDez(10) As String
Dim mCen(10) As String
Dim mDecima(10) As String
Dim mPos(11) As String

mPos(1) = "Real"
mPos(2) = "Mil"
mPos(3) = "Milhão"
mPos(4) = "Bilhão"
mPos(5) = "Trilhão"
mPos(6) = "Reais"
mPos(7) = "Mil"
mPos(8) = "Milhões"
mPos(9) = "Bilhões"
mPos(10) = "Trilhões"

mUni(1) = "Um"
mUni(2) = "Dois"
mUni(3) = "Três"
mUni(4) = "Quatro"
mUni(5) = "Cinco"
mUni(6) = "Seis"
mUni(7) = "Sete"
mUni(8) = "Oito"
mUni(9) = "Nove"

'mDecima(0) = "Dez"
mDecima(1) = "Onze"
mDecima(2) = "Doze"
mDecima(3) = "Treze"
mDecima(4) = "Quatorze"
mDecima(5) = "Quinze"
mDecima(6) = "Dezesseis"
mDecima(7) = "Dezessete"
mDecima(8) = "Dezoito"
mDecima(9) = "Dezenove"

mDez(1) = "Dez"
mDez(2) = "Vinte"
mDez(3) = "Trinta"
mDez(4) = "Quarenta"
mDez(5) = "Cinquenta"
mDez(6) = "Sessenta"
mDez(7) = "Setenta"
mDez(8) = "Oitenta"
mDez(9) = "Noventa"

mCen(1) = "Cento"
mCen(2) = "Duzentos"
mCen(3) = "Trezentos"
mCen(4) = "Quatrocentos"
mCen(5) = "Quinhentos"
mCen(6) = "Seiscentos"
mCen(7) = "Setecentos"
mCen(8) = "Oitocentos"
mCen(9) = "Novecentos"

' Separando Inteiros e Decimais
If InStr(sValor, ",") > 0 Then
sInt = Mid(sValor, 1, InStr(sValor, ",") - 1)
sDec = Mid(sValor, InStr(sValor, ",") + 1)
Else
sInt = sValor
sDec = ""
End If

' Dando nome aos Bois
Dim nPos As Number, nDig As Number, sValorExtenso As String, nPosGeral As Number

' Inteiro
sExt = ""
nI = Len(sInt)
nPos = 1
nPosGeral = 1
Do While nI > 0

nDig = Val(Mid(sInt, nI, 1))
If nPos = 1 Then

' Particularidades da Unidade: Verificando se é um valor entre 11 e 19
If nI > 1 Then
If Val(Mid(sInt, nI - 1, 1)) = 1 Then
if nDig = 0 then
sExt="dez"
else
sExt = mDecima(nDig)
end if
nPos = 2
nI = nI - 1
End If
End If

' Não atendeu, simplesmente recupera o nome
If sExt = "" And nDig > 0 Then
sExt = mUni(nDig)
End If

ElseIf nPos = 2 And nDig > 0 Then

' Dezenas
If Val(Mid(sInt, nI + 1, 1)) = 0 Then
sExt = mDez(nDig)
Else
sExt = mDez(nDig) & " e " & sExt
End If

ElseIf nPos = 3 And nDig > 0 Then

' Centenas
If sExt = "" Then
if nDig = 1 then
sExt = "cem"
else
sExt = mCen(nDig)
end if
Else
sExt = mCen(nDig) & " e " & sExt
End If

End If

nI = nI - 1
nPos = nPos + 1

' Gravando o Total
If nPos = 4 Or nI = 0 Then

If sExt <> "" Then

If sExt = "um" Then
sExt = sExt & " " & mPos(nPosGeral)
Else
sExt = sExt & " " & mPos(nPosGeral + 5)
End If

If sValorExtenso <> "" Then
sValorExtenso = sExt & ", " & sValorExtenso
Else
sValorExtenso = sExt
End If

End If

sExt = ""
nPosGeral = nPosGeral + 1
nPos = 1

End If

Loop

If Right(sValorExtenso, 5) <> "reais" and Right(sValorExtenso, 4) <> "real" Then
sValorExtenso = sValorExtenso & " reais"
End If

' Decimais
If Val(sDec) > 0 Then

If Len(sDec) = 1 Then
sDec = sDec & "0"
ElseIf Len(sDec) > 2 Then
sDec = Mid(sDec, 1, 2)
End If

sExt = ""
For nI = 1 To 2

nDig = Val(Mid(sDec, nI, 1))
If nI = 1 Then
If nDig = 1 And Val(Mid(sDec, 2, 1)) > 0 Then
sExt = mDecima(Val(Mid(sDec, 2, 1)))
exit for
Else
if nDig > 0 then
sExt = mDez(nDig)
If Val(Mid(sDec, 2, 1)) > 0 Then sExt = sExt & " e "
end if
End If
Else
If nDig > 0 Then
sExt = sExt & mUni(nDig)
End If
End If

Next nI

if sExt = "um" then
sExt="um centavo"
else
sExt=sExt & " centavos"
end if

If sExt <> "" Then
sValorExtenso = sValorExtenso & " e " & sExt
End If

End If

ValorExtenso = sValorExtenso
end function


