Attribute VB_Name = "Linuxfacil" Sub Extenso() ' ' ' Extenso Macro ' ' ' Selection.MoveLeft unit:=wdWord, Count:=1, Extend:=wdExtend On Error GoTo Erro Selection.MoveStartUntil cset:=" ", Count:=wdBackward ' Jm MEXEU AQUI Selection.TypeText FormatCurrency(Selection.Text, 2) & " (" & ConverterParaExtenso(Selection.Text) & ")" Selection.TypeText FormatNumber(Selection.Text, 0) & " ( " & ConverterParaExtenso(Selection.Text) & " )" GoTo Pula Erro: MsgBox "O valor deve ser informado sem ponto e sem 'R$'." & Chr$(10) & "O cursor deve estar imediatamente após o valor." _ & Chr$(10) & "O valor não pode estar em início de parágrafo." & Chr$(10) & _ "Exemplo: 1250,35", vbCritical, "Dados inválidos!" Exit Sub Pula: End Sub Public Function ConverterParaExtenso(NumeroParaConverter As String) As String Dim sExtensoFinal As String, sExtensoAtual As String Dim i As Integer Dim iQtdGrupos As Integer Dim sDecimais As String Dim sMoedaSing As String, sMoedaPlu As String, sCentavos As String, sConector As String Dim bSufMoeda As Boolean Dim vArrCenten As Variant 'Separa os Decimais If InStr(1, NumeroParaConverter, ",") > 0 Then sDecimais = Right(NumeroParaConverter, Len(NumeroParaConverter) - InStr(1, NumeroParaConverter, ",")) NumeroParaConverter = Mid(NumeroParaConverter, 1, InStr(1, NumeroParaConverter, ",") - 1) End If 'Obtém a separação de milhares iQtdGrupos = Fix(Len(NumeroParaConverter) / 3) If Len(NumeroParaConverter) Mod 3 > 0 Then iQtdGrupos = iQtdGrupos + 1 End If 'Chama as funções para escrever o número If iQtdGrupos > 2 Then bSufMoeda = True For i = iQtdGrupos To 1 Step -1 sExtensoAtual = DesmembraValor(NumeroParaConverter, i) If i = 1 Then If sExtensoAtual = "" Then sExtensoFinal = sExtensoFinal & sExtensoAtual Else If sExtensoFinal = "" Then sExtensoFinal = sExtensoFinal & sExtensoAtual Else vArrCenten = Array("cem", "duzentos", "trezentos", "quatrocentos", _ "quinhentos", "seiscentos", "setecentos", "oitocentos", "novecentos") sConector = "" For w = 0 To 8 If Len(NumeroParaConverter) >= 4 And Right(NumeroParaConverter, 2) = "00" _ And sExtensoAtual <> vArrCenten(w) Then sConector = "e " Exit For Next w If Len(NumeroParaConverter) >= 4 And Left(Right(NumeroParaConverter, 3), 1) = "0" Then sConector = " e " If Len(NumeroParaConverter) >= 4 And sExtensoAtual = "cem" Then sConector = " e " sExtensoFinal = sExtensoFinal & sConector & sExtensoAtual End If End If Else sExtensoFinal = sExtensoFinal & sExtensoAtual End If If iQtdGrupos > 2 Then Select Case i Case 1, 2 If sExtensoAtual <> "" Then bSufMoeda = False End If End Select End If Next i 'Define a moeda sMoedaPlu = " reais" sMoedaSing = " real" If bSufMoeda = True Then sMoedaPlu = " de reais" 'Escreve os Centavos sCentavos = EscreveCentavos(sDecimais) 'Adiciona a moeda e os centavos ' Jm MEXEU AQUI sExtensoFinal = IIf((sExtensoFinal = ""), "", sExtensoFinal & IIf((sExtensoFinal = "um"), sMoedaSing, sMoedaPlu)) _ & IIf((sExtensoFinal = ""), sCentavos, IIf((sCentavos = ""), "", " e " & sCentavos)) sExtensoFinal = IIf((sExtensoFinal = ""), "", sExtensoFinal & IIf((sExtensoFinal = "um"), "", "")) _ & IIf((sExtensoFinal = ""), sCentavos, IIf((sCentavos = ""), "", " e " & sCentavos)) 'retorna o resultado sExtensoFinal = Replace(sExtensoFinal, " ", " ", 1, , vbTextCompare) ConverterParaExtenso = Replace(sExtensoFinal, "e e ", "e ", 1, , vbTextCompare) End Function Private Function DesmembraValor(sValor As String, iGrupoDiv As Integer) As String Dim iValor As Integer Dim sExtenso As String Dim iDivResto As Integer Dim iDivInteiro As Integer Dim iPosInicMid As Integer Dim iTamMid As Integer Dim sComplemento As String Dim vArrDez1 As Variant Dim vArrDez2 As Variant Dim vArrCentena As Variant vArrDez1 = Array("", "um", "dois", "três", "quatro", "cinco", "seis", "sete", "oito", "nove", _ "dez", "onze", "doze", "treze", "quatorze", "quinze", "dezesseis", "dezessete", _ "dezoito", "dezenove") vArrDez2 = Array("vinte", "trinta", "quarenta", "cinquenta", "sessenta", _ "setenta", "oitenta", "noventa") vArrCentena = Array("cem", "cento", "duzentos", "trezentos", "quatrocentos", _ "quinhentos", "seiscentos", "setecentos", "oitocentos", "novecentos") 'Pega o Valor a ser escrito e desmembra para o grupo numŽrico correto iPosInicMid = Len(sValor) - ((3 * iGrupoDiv) - 1) If iPosInicMid <= 1 Then iTamMid = 2 + iPosInicMid Else iTamMid = 3 End If If iPosInicMid < 1 Then iPosInicMid = 1 iValor = CInt(Mid(sValor, iPosInicMid, iTamMid)) Select Case iGrupoDiv Case 2 sComplemento = " mil " Case 3 If iValor = 1 Then sComplemento = " milhão " Else sComplemento = " milhões " End If Case 4 If iValor = 1 Then sComplemento = " bilhão " Else sComplemento = " bilhões " End If Case 5 If iValor = 1 Then sComplemento = " trilhão " Else sComplemento = " trilhões " End If End Select Select Case iValor Case 0 To 19 sExtenso = vArrDez1(iValor) Case 20 To 99 iDivInteiro = Fix(iValor / 10) iDivResto = iValor Mod 10 If iDivResto = 0 Then sExtenso = vArrDez2(iDivInteiro - 2) Else sExtenso = vArrDez2(iDivInteiro - 2) & " e " & vArrDez1(iDivResto) End If Case 100 To 999 iDivInteiro = Fix(iValor / 100) iDivResto = iValor Mod 100 If iDivResto = 0 Then If iDivInteiro = 1 Then sExtenso = vArrCentena(0) 'Cem Else sExtenso = vArrCentena(iDivInteiro) 'inteiro maior que 100 End If Else sExtenso = vArrCentena(iDivInteiro) & " e " Select Case iDivResto Case 0 To 19 sExtenso = sExtenso & vArrDez1(iDivResto) Case 20 To 99 iDivInteiro2 = Fix(iDivResto / 10) iDivResto2 = iDivResto Mod 10 If iDivResto2 = 0 Then sExtenso = sExtenso & vArrDez2(iDivInteiro2 - 2) Else sExtenso = sExtenso & vArrDez2(iDivInteiro2 - 2) & " e " & vArrDez1(iDivResto2) End If End Select End If End Select If sExtenso = "um" And sComplemento = " mil " And Len(sValor) < 7 Then sComplemento = "mil " sExtenso = "" End If smilx = Right(sValor, 6) If sComplemento = " milhão " Then If Left(smilx, 2) = "00" And Right(smilx, 5) <> "00000" Then sComplemento = " milhão e " Else sComplemento = " milhão " End If If sComplemento = " milhões " Then If Right(smilx, 6) = "000000" Then sComplemento = " milhões " Else If Left(smilx, 2) = "00" And Right(smilx, 5) <> "00000" Then sComplemento = " milhões e " Else sComplemento = " milhões " End If End If DesmembraValor = sExtenso & IIf(iValor > 0, sComplemento, "") End Function Private Function EscreveCentavos(sCent As String) As String Dim sExtenso As String Dim iDivResto As Integer Dim iDivInteiro As Integer Dim sComplemento As String Dim vArrDez1 As Variant Dim vArrDez2 As Variant Dim iCent As Integer vArrDez1 = Array("", "um", "dois", "três", "quatro", "cinco", "seis", "sete", "oito", "nove", _ "dez", "onze", "doze", "treze", "quatorze", "quinze", "dezesseis", "dezessete", _ "dezoito", "dezenove") vArrDez2 = Array("vinte", "trinta", "quarenta", "cinquenta", "sessenta", _ "setenta", "oitenta", "noventa") 'Adequando para duas casas decimais iCent = Fix(sCent & String(2 - Len(sCent), "0")) 'Escrevendo Singular ou plural If iCent = 1 Then sComplemento = " centavo" Else sComplemento = " centavos" End If 'Calculando os valores Select Case iCent Case 0 To 19 sExtenso = vArrDez1(iCent) Case 20 To 99 iDivInteiro = Fix(iCent / 10) iDivResto = iCent Mod 10 If iDivResto = 0 Then sExtenso = vArrDez2(iDivInteiro - 2) Else sExtenso = vArrDez2(iDivInteiro - 2) & " e " & vArrDez1(iDivResto) End If End Select EscreveCentavos = IIf(iCent > 0, sExtenso & sComplemento, "") End Function