tutoriais

Escrevendo valores monetários por extenso

Vamos ver nessa videoaula como criar uma macro para escrever números por extenso utilizando o Word.

 Assiata a videoaula. A seguir está disponibilizado o código a ser inserido na macro.

+ - Assista a videoaula Click to collapse

O nosso querido Walter Nascimento sugeriu que alguns autores apontam como desnecessário o uso de vírgulas quando apresentamos o número por extenso. Por conta disso fiz a alteração necessária no código e montei um arquivo onde coloquei dois códigos. Um que apresenta as vírgulas e outro que não apresenta, haja vista que pesquisei na internet e não consegui uma resposta definitiva sobre a proibição de utilizar as vírgulas. Baixe o arquivo, descompacte e utilize o que desejar.
Acesse o arquivo aqui

Se preferir, copie o código diretamente daqui:

+ - COM a utilização de Vírgulas Click to collapse 
Public Sub Escrever_Extenso()
Dim Num As String
If IsNumeric(Selection) Then
Num = CDbl(Selection)
Selection.InsertAfter " " & " (" & ExtensoHum(Num, False, False) & ") "
Selection.Start = Selection.End
Else
MsgBox "Isso não é número !"
End If
End Sub
Function ExtensoHum(nValor As String, Optional Hum As Boolean = True, Optional UmMil As Boolean = True) As String
'----------------------------------------------------------- ----------------------------
' Procedimento : ExtensoHum
' Data/Hora : 05/10/06 22:33
' Autor : OsmarJr
' Propósito : Função de extenso mais completa
' ; nValor - recebe o valor a ser convertido
' ; Hum - indica se o um mil deve ser escrito Hum mil ou Um mil (padrão Hum mil)
' ; UmMil - indica se deve ser escrito Um mil ou Mil (padrão Um mil)
'----------------------------------------------------------- ----------------------------
'
'On Error GoTo ExtensoHum_Erro
If IsNull(nValor) Or CCur(nValor) > 999999999.99 Then Exit Function
Dim intContador As Integer
Dim intTamanho As Integer
Dim strValor As String
Dim strParte As String
Dim strFinal As String
Dim strGrupo(4) As String
Dim strTexto(4) As String
Dim strUnid(19) As String
strUnid(1) = "um "
strUnid(2) = "dois "
strUnid(3) = "três "
strUnid(4) = "quatro "
strUnid(5) = "cinco "
strUnid(6) = "seis "
strUnid(7) = "sete "
strUnid(8) = "oito "
strUnid(9) = "nove "
strUnid(10) = "dez "
strUnid(11) = "onze "
strUnid(12) = "doze "
strUnid(13) = "treze "
strUnid(14) = "quatorze "
strUnid(15) = "quinze "
strUnid(16) = "dezesseis "
strUnid(17) = "dezessete "
strUnid(18) = "dezoito "
strUnid(19) = "dezenove "
Dim strDezena(9) As String
strDezena(1) = "dez "
strDezena(2) = "vinte "
strDezena(3) = "trinta "
strDezena(4) = "quarenta "
strDezena(5) = "cinquenta "
strDezena(6) = "sessenta "
strDezena(7) = "setenta "
strDezena(8) = "oitenta "
strDezena(9) = "noventa "
Dim strCentena(9) As String
strCentena(1) = "cento "
strCentena(2) = "duzentos "
strCentena(3) = "trezentos "
strCentena(4) = "quatrocentos "
strCentena(5) = "quinhentos "
strCentena(6) = "seiscentos "
strCentena(7) = "setecentos "
strCentena(8) = "oitocentos "
strCentena(9) = "novecentos "
strValor = Format$(nValor, "0000000000.00")
strGrupo(1) = Mid$(strValor, 2, 3) 'Milhão
strGrupo(2) = Mid$(strValor, 5, 3) 'Milhar
strGrupo(3) = Mid$(strValor, 8, 3) 'Centena
strGrupo(4) = "0" + Mid$(strValor, 12, 2) 'Centavo
For intContador = 1 To 4
strParte = strGrupo(intContador)
intTamanho = Switch(Val(strParte) < 10, 1, Val(strParte) < 100, 2, Val(strParte) < 1000, 3)
If intTamanho = 3 Then
If Right$(strParte, 2) <> "00" Then
strTexto(intContador) = strTexto(intContador) + strCentena(Left(strParte, 1)) + "e "
intTamanho = 2
Else
strTexto(intContador) = strTexto(intContador) + IIf(Left$(strParte, 1) = "1", "cem ", strCentena(Left(strParte, 1)))
End If
End If
If intTamanho = 2 Then
If Val(Right(strParte, 2)) < 20 Then
strTexto(intContador) = strTexto(intContador) + strUnid(Right(strParte, 2))
Else
strTexto(intContador) = strTexto(intContador) + strDezena(Mid(strParte, 2, 1))
If Right$(strParte, 1) <> "0" Then
strTexto(intContador) = strTexto(intContador) + "e "
intTamanho = 1
End If
End If
End If
If intTamanho = 1 Then
strTexto(intContador) = strTexto(intContador) + strUnid(Right(strParte, 1))
End If
Next intContador
'Gera o formato final do texto
If Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strTexto(4) + IIf(Val(strGrupo(4)) = 1, "centavo", "centavos")
Else
strFinal = ""
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões de ", "milhão de "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões e ", "milhão e "), "")
End If
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões e ", "milhão e "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões ", "milhão "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões ", "milhão "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões ", "milhão "), "")
End If
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões de ", "milhão de "), "")
End If
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões ", "milhão "), "")
End If
If Val(strGrupo(3)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil ", "")
Else
If Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil e ", "")
Else
strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil ", "")
End If
End If
If Val(strGrupo(4)) = 0 Then
strFinal = strFinal + strTexto(3) + IIf(Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 1, "real ", "reais ")
Else
strFinal = strFinal + strTexto(3) + IIf(Val(strGrupo(3)) <> 1, IIf(Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 1, "real ", "reais "), "real ")
End If
strFinal = strFinal + IIf(Val(strGrupo(4)) <> 0, "e " + strTexto(4) + IIf(Val(strGrupo(4)) = 1, "centavo", "centavos"), "")
End If
If Hum Then
If Left(strFinal, 7) = "um mil" Then
strFinal = "H" & strFinal
End If
End If
If Hum And Not UmMil Then
If Left(strFinal, 8) = "hum mil" Then
strFinal = "Mil e " & Right(strFinal, Len(strFinal) - 8)
End If
End If
If Not Hum And Not UmMil Then
If Left(strFinal, 7) = "um mil" Then
strFinal = "Mil e " & Right(strFinal, Len(strFinal) - 7)
End If
End If
ExtensoHum = UCase(Mid$(strFinal, 1, 1)) & Mid$(strFinal, 2)
ExtensoHum = Trim(ExtensoHum)
Saida:
Exit Function
ExtensoHum_Erro:
MsgBox "Erro: " & vbCrLf & vbCrLf & Err.Description & vbCrLf & " no procedimento ExtensoHum", vbExclamation + vbOKOnly, "Erro: " & CStr(Err.Number)
Resume Saida
End Function
Public Function ExtensoX(nValor As String) As String
'On Error GoTo Sai
If IsNull(nValor) Or nValor > 999999999.99 Then Exit Function
Dim intContador As Integer
Dim intTamanho As Integer
Dim strValor As String
Dim strParte As String
Dim strFinal As String
Dim strGrupo(4) As String
Dim strTexto(4) As String
Dim strUnid(19) As String
strUnid(1) = "um "
strUnid(2) = "dois "
strUnid(3) = "três "
strUnid(4) = "quatro "
strUnid(5) = "cinco "
strUnid(6) = "seis "
strUnid(7) = "sete "
strUnid(8) = "oito "
strUnid(9) = "nove "
strUnid(10) = "dez "
strUnid(11) = "onze "
strUnid(12) = "doze "
strUnid(13) = "treze "
strUnid(14) = "quatorze "
strUnid(15) = "quinze "
strUnid(16) = "dezesseis "
strUnid(17) = "dezessete "
strUnid(18) = "dezoito "
strUnid(19) = "dezenove "
Dim strDezena(9) As String
strDezena(1) = "dez "
strDezena(2) = "vinte "
strDezena(3) = "trinta "
strDezena(4) = "quarenta "
strDezena(5) = "cinqüenta "
strDezena(6) = "sessenta "
strDezena(7) = "setenta "
strDezena(8) = "oitenta "
strDezena(9) = "noventa "
Dim strCentena(9) As String
strCentena(1) = "cento "
strCentena(2) = "duzentos "
strCentena(3) = "trezentos "
strCentena(4) = "quatrocentos "
strCentena(5) = "quinhentos "
strCentena(6) = "seiscentos "
strCentena(7) = "setecentos "
strCentena(8) = "oitocentos "
strCentena(9) = "novecentos "
strValor = Format$(nValor, "0000000000.00")
strGrupo(1) = Mid$(strValor, 2, 3) 'Milhão
strGrupo(2) = Mid$(strValor, 5, 3) 'Milhar
strGrupo(3) = Mid$(strValor, 8, 3) 'Centena
strGrupo(4) = "0" + Mid$(strValor, 12, 2) 'Centavo
For intContador = 1 To 4
strParte = strGrupo(intContador)
intTamanho = Switch(Val(strParte) < 10, 1, Val(strParte) < 100, 2, Val(strParte) < 1000, 3)
If intTamanho = 3 Then
If Right$(strParte, 2) <> "00" Then
strTexto(intContador) = strTexto(intContador) + strCentena(Left(strParte, 1)) + "e "
intTamanho = 2
Else
strTexto(intContador) = strTexto(intContador) + IIf(Left$(strParte, 1) = "1", "cem ", strCentena(Left(strParte, 1)))
End If
End If
If intTamanho = 2 Then
If Val(Right(strParte, 2)) < 20 Then
strTexto(intContador) = strTexto(intContador) + strUnid(Right(strParte, 2))
Else
strTexto(intContador) = strTexto(intContador) + strDezena(Mid(strParte, 2, 1))
If Right$(strParte, 1) <> "0" Then
strTexto(intContador) = strTexto(intContador) + "e "
intTamanho = 1
End If
End If
End If
If intTamanho = 1 Then
strTexto(intContador) = strTexto(intContador) + strUnid(Right(strParte, 1))
End If
Next intContador
'Gera o formato final do texto
If Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strTexto(4) + IIf(Val(strGrupo(4)) = 1, "centavo", "centavos")
Else
strFinal = ""
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões de ", "milhão de "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões e ", "milhão e "), "")
End If
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões e ", "milhão e "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões ", "milhão "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões ", "milhão "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões ", "milhão "), "")
End If
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões de ", "milhão de "), "")
End If
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões ", "milhão "), "")
End If
If Val(strGrupo(3)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil ", "")
Else
If Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil e ", "")
Else
strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil ", "")
End If
End If
If Val(strGrupo(4)) = 0 Then
strFinal = strFinal + strTexto(3) + IIf(Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 1, "real ", "reais ")
Else
strFinal = strFinal + strTexto(3) + IIf(Val(strGrupo(3)) <> 1, IIf(Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 1, "real ", "reais "), "real ")
End If
strFinal = strFinal + IIf(Val(strGrupo(4)) <> 0, "e " + strTexto(4) + IIf(Val(strGrupo(4)) = 1, "centavo", "centavos"), "")
End If
If Left(strFinal, 1) = "u" Then
ExtensoX = "H" & Mid$(strFinal, 1)
Else
ExtensoX = UCase(Mid$(strFinal, 1, 1)) & Mid$(strFinal, 2)
End If
Dim aux As String * 250
aux = Trim(ExtensoX)
ExtensoX = Trim(aux)
Sai1:
Exit Function
Sai:
Dim NadaV As Long
NadaV = MsgBox("Ocorreu o erro nº" & Err.Number & Chr(13) & Err.Description & Chr(13) & Chr(13) & "Se o problema persistir, entre em contato com o supervisor!", vbCritical)
Resume Sai1
End Function
Public Function LPad(s, ByVal C As String, n As Integer) As String
'
' Acrescenta o caracter C à esquerda da string S justificando-a à direita
'
If Len© = 0 Then C = " "
If n < 1 Then
LPad = ""
Else
LPad = Right$(String$(n, Left$(C, 1)) & s, n)
End If
End Function
Function DPad(s, n As Integer, Optional C As String = " ") As String
'
' Acrescenta o caracter C à direita da string S para fazer justificação à esquerda
'
If Len© = 0 Then C = " "
If n < 1 Then
DPad = ""
Else
DPad = Left$(s & String$(n, Left$(C, 1)), n)
End If
End Function
+ - SEM a utilização de Vírgulas Click to collapse 
Public Sub Escrever_Extenso()
Dim Num As String
If IsNumeric(Selection) Then
Num = CDbl(Selection)
Selection.InsertAfter " " & " (" & ExtensoHum(Num, False, False) & ") "
Selection.Start = Selection.End
Else
MsgBox "Isso não é número !"
End If
End Sub
Function ExtensoHum(nValor As String, Optional Hum As Boolean = True, Optional UmMil As Boolean = True) As String
'----------------------------------------------------------- ----------------------------
' Procedimento : ExtensoHum
' Data/Hora : 05/10/06 22:33
' Autor : OsmarJr
' Propósito : Função de extenso mais completa
' ; nValor - recebe o valor a ser convertido
' ; Hum - indica se o um mil deve ser escrito Hum mil ou Um mil (padrão Hum mil)
' ; UmMil - indica se deve ser escrito Um mil ou Mil (padrão Um mil)
'----------------------------------------------------------- ----------------------------
'
'On Error GoTo ExtensoHum_Erro
If IsNull(nValor) Or CCur(nValor) > 999999999.99 Then Exit Function
Dim intContador As Integer
Dim intTamanho As Integer
Dim strValor As String
Dim strParte As String
Dim strFinal As String
Dim strGrupo(4) As String
Dim strTexto(4) As String
Dim strUnid(19) As String
strUnid(1) = "um "
strUnid(2) = "dois "
strUnid(3) = "três "
strUnid(4) = "quatro "
strUnid(5) = "cinco "
strUnid(6) = "seis "
strUnid(7) = "sete "
strUnid(8) = "oito "
strUnid(9) = "nove "
strUnid(10) = "dez "
strUnid(11) = "onze "
strUnid(12) = "doze "
strUnid(13) = "treze "
strUnid(14) = "quatorze "
strUnid(15) = "quinze "
strUnid(16) = "dezesseis "
strUnid(17) = "dezessete "
strUnid(18) = "dezoito "
strUnid(19) = "dezenove "
Dim strDezena(9) As String
strDezena(1) = "dez "
strDezena(2) = "vinte "
strDezena(3) = "trinta "
strDezena(4) = "quarenta "
strDezena(5) = "cinquenta "
strDezena(6) = "sessenta "
strDezena(7) = "setenta "
strDezena(8) = "oitenta "
strDezena(9) = "noventa "
Dim strCentena(9) As String
strCentena(1) = "cento "
strCentena(2) = "duzentos "
strCentena(3) = "trezentos "
strCentena(4) = "quatrocentos "
strCentena(5) = "quinhentos "
strCentena(6) = "seiscentos "
strCentena(7) = "setecentos "
strCentena(8) = "oitocentos "
strCentena(9) = "novecentos "
strValor = Format$(nValor, "0000000000.00")
strGrupo(1) = Mid$(strValor, 2, 3) 'Milhão
strGrupo(2) = Mid$(strValor, 5, 3) 'Milhar
strGrupo(3) = Mid$(strValor, 8, 3) 'Centena
strGrupo(4) = "0" + Mid$(strValor, 12, 2) 'Centavo
For intContador = 1 To 4
strParte = strGrupo(intContador)
intTamanho = Switch(Val(strParte) < 10, 1, Val(strParte) < 100, 2, Val(strParte) < 1000, 3)
If intTamanho = 3 Then
If Right$(strParte, 2) <> "00" Then
strTexto(intContador) = strTexto(intContador) + strCentena(Left(strParte, 1)) + "e "
intTamanho = 2
Else
strTexto(intContador) = strTexto(intContador) + IIf(Left$(strParte, 1) = "1", "cem ", strCentena(Left(strParte, 1)))
End If
End If
If intTamanho = 2 Then
If Val(Right(strParte, 2)) < 20 Then
strTexto(intContador) = strTexto(intContador) + strUnid(Right(strParte, 2))
Else
strTexto(intContador) = strTexto(intContador) + strDezena(Mid(strParte, 2, 1))
If Right$(strParte, 1) <> "0" Then
strTexto(intContador) = strTexto(intContador) + "e "
intTamanho = 1
End If
End If
End If
If intTamanho = 1 Then
strTexto(intContador) = strTexto(intContador) + strUnid(Right(strParte, 1))
End If
Next intContador
'Gera o formato final do texto
If Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strTexto(4) + IIf(Val(strGrupo(4)) = 1, "centavo", "centavos")
Else
strFinal = ""
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões de ", "milhão de "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões e ", "milhão e "), "")
End If
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões e ", "milhão e "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões ", "milhão "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões ", "milhão "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões ", "milhão "), "")
End If
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões de ", "milhão de "), "")
End If
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões ", "milhão "), "")
End If
If Val(strGrupo(3)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil ", "")
Else
If Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil e ", "")
Else
strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil ", "")
End If
End If
If Val(strGrupo(4)) = 0 Then
strFinal = strFinal + strTexto(3) + IIf(Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 1, "real ", "reais ")
Else
strFinal = strFinal + strTexto(3) + IIf(Val(strGrupo(3)) <> 1, IIf(Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 1, "real ", "reais "), "real ")
End If
strFinal = strFinal + IIf(Val(strGrupo(4)) <> 0, "e " + strTexto(4) + IIf(Val(strGrupo(4)) = 1, "centavo", "centavos"), "")
End If
If Hum Then
If Left(strFinal, 7) = "um mil" Then
strFinal = "H" & strFinal
End If
End If
If Hum And Not UmMil Then
If Left(strFinal, 8) = "hum mil" Then
strFinal = "Mil e " & Right(strFinal, Len(strFinal) - 8)
End If
End If
If Not Hum And Not UmMil Then
If Left(strFinal, 7) = "um mil" Then
strFinal = "Mil e " & Right(strFinal, Len(strFinal) - 7)
End If
End If
ExtensoHum = UCase(Mid$(strFinal, 1, 1)) & Mid$(strFinal, 2)
ExtensoHum = Trim(ExtensoHum)
Saida:
Exit Function
ExtensoHum_Erro:
MsgBox "Erro: " & vbCrLf & vbCrLf & Err.Description & vbCrLf & " no procedimento ExtensoHum", vbExclamation + vbOKOnly, "Erro: " & CStr(Err.Number)
Resume Saida
End Function
Public Function ExtensoX(nValor As String) As String
'On Error GoTo Sai
If IsNull(nValor) Or nValor > 999999999.99 Then Exit Function
Dim intContador As Integer
Dim intTamanho As Integer
Dim strValor As String
Dim strParte As String
Dim strFinal As String
Dim strGrupo(4) As String
Dim strTexto(4) As String
Dim strUnid(19) As String
strUnid(1) = "um "
strUnid(2) = "dois "
strUnid(3) = "três "
strUnid(4) = "quatro "
strUnid(5) = "cinco "
strUnid(6) = "seis "
strUnid(7) = "sete "
strUnid(8) = "oito "
strUnid(9) = "nove "
strUnid(10) = "dez "
strUnid(11) = "onze "
strUnid(12) = "doze "
strUnid(13) = "treze "
strUnid(14) = "quatorze "
strUnid(15) = "quinze "
strUnid(16) = "dezesseis "
strUnid(17) = "dezessete "
strUnid(18) = "dezoito "
strUnid(19) = "dezenove "
Dim strDezena(9) As String
strDezena(1) = "dez "
strDezena(2) = "vinte "
strDezena(3) = "trinta "
strDezena(4) = "quarenta "
strDezena(5) = "cinqüenta "
strDezena(6) = "sessenta "
strDezena(7) = "setenta "
strDezena(8) = "oitenta "
strDezena(9) = "noventa "
Dim strCentena(9) As String
strCentena(1) = "cento "
strCentena(2) = "duzentos "
strCentena(3) = "trezentos "
strCentena(4) = "quatrocentos "
strCentena(5) = "quinhentos "
strCentena(6) = "seiscentos "
strCentena(7) = "setecentos "
strCentena(8) = "oitocentos "
strCentena(9) = "novecentos "
strValor = Format$(nValor, "0000000000.00")
strGrupo(1) = Mid$(strValor, 2, 3) 'Milhão
strGrupo(2) = Mid$(strValor, 5, 3) 'Milhar
strGrupo(3) = Mid$(strValor, 8, 3) 'Centena
strGrupo(4) = "0" + Mid$(strValor, 12, 2) 'Centavo
For intContador = 1 To 4
strParte = strGrupo(intContador)
intTamanho = Switch(Val(strParte) < 10, 1, Val(strParte) < 100, 2, Val(strParte) < 1000, 3)
If intTamanho = 3 Then
If Right$(strParte, 2) <> "00" Then
strTexto(intContador) = strTexto(intContador) + strCentena(Left(strParte, 1)) + "e "
intTamanho = 2
Else
strTexto(intContador) = strTexto(intContador) + IIf(Left$(strParte, 1) = "1", "cem ", strCentena(Left(strParte, 1)))
End If
End If
If intTamanho = 2 Then
If Val(Right(strParte, 2)) < 20 Then
strTexto(intContador) = strTexto(intContador) + strUnid(Right(strParte, 2))
Else
strTexto(intContador) = strTexto(intContador) + strDezena(Mid(strParte, 2, 1))
If Right$(strParte, 1) <> "0" Then
strTexto(intContador) = strTexto(intContador) + "e "
intTamanho = 1
End If
End If
End If
If intTamanho = 1 Then
strTexto(intContador) = strTexto(intContador) + strUnid(Right(strParte, 1))
End If
Next intContador
'Gera o formato final do texto
If Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strTexto(4) + IIf(Val(strGrupo(4)) = 1, "centavo", "centavos")
Else
strFinal = ""
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões de ", "milhão de "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões e ", "milhão e "), "")
End If
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões e ", "milhão e "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões ", "milhão "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões ", "milhão "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões ", "milhão "), "")
End If
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões de ", "milhão de "), "")
End If
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões ", "milhão "), "")
End If
If Val(strGrupo(3)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil ", "")
Else
If Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil e ", "")
Else
strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil ", "")
End If
End If
If Val(strGrupo(4)) = 0 Then
strFinal = strFinal + strTexto(3) + IIf(Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 1, "real ", "reais ")
Else
strFinal = strFinal + strTexto(3) + IIf(Val(strGrupo(3)) <> 1, IIf(Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 1, "real ", "reais "), "real ")
End If
strFinal = strFinal + IIf(Val(strGrupo(4)) <> 0, "e " + strTexto(4) + IIf(Val(strGrupo(4)) = 1, "centavo", "centavos"), "")
End If
If Left(strFinal, 1) = "u" Then
ExtensoX = "H" & Mid$(strFinal, 1)
Else
ExtensoX = UCase(Mid$(strFinal, 1, 1)) & Mid$(strFinal, 2)
End If
Dim aux As String * 250
aux = Trim(ExtensoX)
ExtensoX = Trim(aux)
Sai1:
Exit Function
Sai:
Dim NadaV As Long
NadaV = MsgBox("Ocorreu o erro nº" & Err.Number & Chr(13) & Err.Description & Chr(13) & Chr(13) & "Se o problema persistir, entre em contato com o supervisor!", vbCritical)
Resume Sai1
End Function
Public Function LPad(s, ByVal C As String, n As Integer) As String
'
' Acrescenta o caracter C à esquerda da string S justificando-a à direita
'
If Len© = 0 Then C = " "
If n < 1 Then
LPad = ""
Else
LPad = Right$(String$(n, Left$(C, 1)) & s, n)
End If
End Function
Function DPad(s, n As Integer, Optional C As String = " ") As String
'
' Acrescenta o caracter C à direita da string S para fazer justificação à esquerda
'
If Len© = 0 Then C = " "
If n < 1 Then
DPad = ""
Else
DPad = Left$(s & String$(n, Left$(C, 1)), n)
End If
End Function

© 2022. Desenvolvido por JBFloripa

Viabilizado com o apoio incondicional da Rê e imensas doses de cafeína!
Hospedado em ITM Networks (clique e contrate uma hospedagem), que eu recomendo a todos!

Todo o conteúdo desse site está sob Licença Creative Commons Atribuição-NãoComercial 4.0 Internacional