Dicas & Macetes: Microsoft Word

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.

Código para inserir na macro. Copie e cole:

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

 

Projeto Inclusão Digital © 2017 - 2018 (Hospedado em ITM Networks)
Todo o material desse site está disponível gratuitamente para todos que desejarem utilizar.
Pedimos que sejam preservados os direitos de compilação do material.
Feito com muita cafeína e apoio incondicional da Rê.