estevaogsr

Pegando a deixa dos dois posts: Segue a macro atualizada para até 4 casas decimais, distinguindo décimos de centésimos. '*****************Código original de: Eduardo (eduzsrj) 07/02/2011*****************' 'https://www.clubedohardware.com.br/forums/topic/817427-dica-ms-office-valor-por-extenso-no-word/' '' '*****************Código adaptado: Luan (luangabs) 10/03/2017*****************' 'https://www.clubedohardware.com.br/forums/topic/1219410-dica-ms-office-valor-percentual-por-extenso-no-word/' '' '*****************Código adaptado: Estevão (estevaogsr) 08/07/2020*****************' '' '*****************Notas de nova versão:*****************' 'Escreve por extenso até quatro casas decimais(milésimos)' 'Só escreve o sufixo inteiro quando é um numero decimal' 'Distingue décimos de centésimos' Sub WValorExtensoPerc() ' Selection.MoveLeft unit:=wdWord, Count:=1, Extend:=wdExtend On Error GoTo Erro Selection.MoveStartUntil cset:=" ", Count:=wdBackward Selection.TypeText Selection.Text & "%" & " (" & ConverterParaExtensoPerc(Selection.Text) & " por cento" & ")" 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 ConverterParaExtensoPerc(NumeroParaConverter As String) As String Dim sExtensoFinal As String, sExtensoAtual As String Dim i As Integer Dim iQtdGrupos As Integer Dim Original As String Dim sDecimais As String Dim sTipoSing As String, sTipoPlu As String, sDecimos As String, sConector As String Dim bSufTipo As Boolean Dim vArrCenten As Variant Original = NumeroParaConverter '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 bSufTipo = 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 bSufTipo = False End If End Select End If Next i 'Define o tipo If Original = Int(Original) Then sTipoPlu = "" sTipoSing = "" Else sTipoPlu = " inteiros" sTipoSing = "" End If If bSufTipo = True Then sTipoPlu = " de inteiros" 'Escreve os décimos sDecimos = EscreveDecimosPerc(sDecimais) 'Adiciona os décimos e se é plural ou singular sExtensoFinal = IIf((sExtensoFinal = ""), "", sExtensoFinal & IIf((sExtensoFinal = "um"), sTipoSing, sTipoPlu)) _ & IIf((sExtensoFinal = ""), sDecimos, IIf((sDecimos = ""), "", " e " & sDecimos)) 'retorna o resultado sExtensoFinal = Replace(sExtensoFinal, " ", " ", 1, , vbTextCompare) ConverterParaExtensoPerc = 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 EscreveDecimosPerc(sCent As String) As String Dim sExtenso As String Dim iDivResto As Integer Dim iDivResto2 As Integer Dim iDivResto3 As Integer Dim iDivResto4 As Integer Dim iDivInteiro As Integer Dim iDivInteiro2 As Integer Dim iDivInteiro3 As Integer Dim iDivInteiro4 As Integer Dim sComplemento As String Dim vArrDez1 As Variant Dim vArrDez2 As Variant Dim vArrCen As Variant Dim vArrMilhar As Variant Dim iCent As Integer Dim iLenght 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") vArrCen = Array("cem", "cento", "duzentos", "trezentos", "quatrocentos", _ "quinhentos", "seiscentos", "setecentos", "oitocentos", "novecentos") vArrMilhar = Array("um mil", "dois mil", "três mil", "quatro mil", _ "cinco mil", "seis mil", "sete mil", "oito mil", "nove mil") 'Separa os Decimais iLenght = Len(sCent) If iLenght = 1 Then 'Adequando para uma casa decimal iCent = Fix(sCent & String(1 - Len(sCent), "0")) 'Escrevendo Singular ou plural If iCent = 1 Then sComplemento = " décimo" Else sComplemento = " décimos" End If ElseIf iLenght = 2 Then 'Adequando para duas casas decimais iCent = Fix(sCent & String(2 - Len(sCent), "0")) 'Escrevendo Singular ou plural If iCent = 1 Then sComplemento = " centésimo" Else sComplemento = " centésimos" End If ElseIf iLenght = 3 Then 'Adequando para tres casas decimais iCent = Fix(sCent & String(3 - Len(sCent), "0")) 'Escrevendo Singular ou plural If iCent = 1 Then sComplemento = " milésimo" Else sComplemento = " milésimos" End If ElseIf iLenght = 4 Then 'Adequando para quatro casas decimais iCent = Fix(sCent & String(4 - Len(sCent), "0")) 'Escrevendo Singular ou plural If iCent = 1 Then sComplemento = " décimo de milésimo" Else sComplemento = " décimos de milésimo" End If 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 Case 100 To 999 iDivInteiro = Fix(iCent / 100) iDivResto = iCent Mod 100 If iDivResto = 0 Then If iDivResto = 1 Then sExtenso = vArrCen(0) 'cem Else sExtenso = vArrCen(iDivInteiro - 1) 'inteiro maior que 100 End If Else sExtenso = vArrCen(iDivInteiro) & " e " 'Concatena a centena com a dezena 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 Case 1000 To 9999 iDivInteiro = Fix(iCent / 1000) iDivResto = iCent Mod 1000 If iDivResto = 0 Then If iDivResto = 1 Then sExtenso = vArrMilhar(0) 'Um Mil Else sExtenso = vArrMilhar(iDivInteiro - 1) 'inteiro maior que 1000 End If Else sExtenso = vArrMilhar(iDivInteiro - 1) & " e " 'Concatena a centena com a centena, dezena ou unidade 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 Case 100 To 999 iDivInteiro3 = Fix(iDivResto / 100) iDivResto3 = iDivResto Mod 100 If iDivResto3 = 0 Then If iDivResto3 = 1 Then sExtenso = sExtenso & vArrCen(0) 'cem Else sExtenso = sExtenso & vArrCen(iDivInteiro3 - 1) 'inteiro maior que 100 End If Else sExtenso = sExtenso & vArrCen(iDivInteiro3) & " e " 'Concatena a centena com a dezena Select Case iDivResto3 Case 0 To 19 sExtenso = sExtenso & vArrDez1(iDivResto3) Case 20 To 99 iDivInteiro4 = Fix(iDivResto3 / 10) iDivResto4 = iDivResto3 Mod 10 If iDivResto4 = 0 Then sExtenso = sExtenso & vArrDez2(iDivInteiro4 - 2) Else sExtenso = sExtenso & vArrDez2(iDivInteiro4 - 2) & " e " & vArrDez1(iDivResto4) End If End Select End If End Select End If End Select EscreveDecimosPerc = IIf(iCent > 0, sExtenso & sComplemento, "") End Function