Function fExtenso(Num As Double, Optional FraçTipo As Integer, Optional UndNomeSing As String, _ Optional UndNomePlur As String, Optional UndMasc As Boolean = True, _ Optional UmMil As Boolean = True, Optional VirgEntrMilh As Boolean = False, _ Optional CaixaAlta As Long = 1) As String Dim ExtensInt As String Dim ExtensFrac As String Dim UndNome As String Dim FracNome As String Dim Signif As Long Dim NumText As String If Num > 999999999999.99 Or Num < 0 Then fExtenso = "Erro! (Valores válidos: >=0 e < 1 trilhão)" Exit Function End If 'Preparando nome da unidade, singular e plural If UndNomePlur = "" Then UndNomePlur = IIf(UndNomeSing = "", "", Pluralizar(UndNomeSing)) 'Se a função Pluralizar falhar palavras estrangeiras ou em exceções portuguesas, o argumento UndNomePlur pode ser usado. 'Extenso parte inteira ExtensInt = fExtensoInt(Int(CDec(Num)), UndMasc, UmMil, VirgEntrMilh) 'Extenso parte fracionária If FraçTipo = 0 And UndNomeSing = "" Then FraçTipo = 3 If FraçTipo = 0 And UndNomeSing <> "" Then FraçTipo = 1 Select Case FraçTipo Case 1, 5 'Lê fração em centavos ou cêntimos. Ideal para Moeda Num = Format(Num, "0.00") * 1 'Round(Num,2) ExtensFrac = fExtensoInt((Num - Int(CDec(Num))) * 100, True, UmMil, VirgEntrMilh) If ExtensInt = "" And ExtensFrac = "" Then ExtensInt = "zero" 'Nome da unidade no singular ou plural UndNome = IIf(Num < 1, IIf(Num = 0, " " & UndNomePlur, ""), IIf(UndNomeSing = "" Or Right(ExtensInt, 1) = " ", "", " ") & IIf(Int(CDec(Num)) = 1, UndNomeSing, UndNomePlur) & IIf(Num = Int(CDec(Num)), "", " e ")) 'Nome da fração no singular ou plural FracNome = IIf(Num = Int(CDec(Num)), "", IIf(Int(CDec(Num * 100)) - Int(CDec(Num)) * 100 = 1, IIf(FraçTipo = 5, " cêntimo", " centavo"), IIf(FraçTipo = 5, " cêntimos", " centavos"))) fExtenso = ExtensInt & UndNome & ExtensFrac & FracNome Case 2 'Lê a vírgula decimal, cada zero e o número restante como inteiro. Ideal para percentual. ExtensFrac = Num - Int(CDec(Num)) If ExtensFrac = 0 Then fExtenso = ExtensInt Else ExtensFrac = Format(ExtensFrac, "0.############") ExtensFrac = Mid(ExtensFrac, 3, 15) fExtenso = IIf(ExtensInt = "", "zero", ExtensInt) & " vírgula" Do While Left(ExtensFrac, 1) = "0" fExtenso = fExtenso & " zero" ExtensFrac = Mid(ExtensFrac, 2, 15) Loop fExtenso = fExtenso & " " & fExtensoInt(ExtensFrac * 1, UndMasc, UmMil, VirgEntrMilh) End If If fExtenso = "" Then fExtenso = "zero" fExtenso = fExtenso & IIf(UndNomeSing <> "", " ", "") & IIf(Num = 1, UndNomeSing, UndNomePlur) Case 3 'Lê a fração de décimo a bilionésimo. Ideal para número puro. ExtensFrac = Num - Int(CDec(Num)) If ExtensFrac = 0 Then ExtensFrac = "" Else ExtensFrac = Format(ExtensFrac, "0.############") Signif = Len(ExtensFrac) - 2 If Signif > 3 And Signif <> 6 And Signif <> 9 And Signif <> 12 Then Signif = Int(CDec(Signif / 3)) * 3 + 3 If Signif > 0 Then ExtensFrac = Format(ExtensFrac, "0.000000000000") ExtensFrac = fExtensoInt(Mid(ExtensFrac, 3, Signif) * 1, True, UmMil, VirgEntrMilh) FracNome = Choose(Signif, "décimo", "centésimo", "milésimo", , , "milionésimo", , , "bilionésimo", , , "trilionésimo") FracNome = " " & FracNome & IIf(ExtensFrac = "um", "", "s") Else ExtensFrac = "" End If End If If ExtensInt = "" And ExtensFrac = "" Then ExtensInt = "zero" If UndNomeSing = "" Then fExtenso = ExtensInt & IIf(ExtensInt <> "" And ExtensFrac <> "", ", e ", "") & ExtensFrac & FracNome Else 'Nome da unidade no singular ou plural UndNome = IIf(Num < 1, IIf(Num = 0, " " & UndNomePlur, ""), IIf(UndNomeSing = "" Or Right(ExtensInt, 1) = " ", "", " ") & IIf(Int(CDec(Num)) = 1, UndNomeSing, UndNomePlur) & IIf(Num = Int(CDec(Num)), "", " e ")) 'Nome da fração no singular ou plural FracNome = IIf(Num = Int(CDec(Num)), "", FracNome & " de " & UndNomeSing) fExtenso = ExtensInt & UndNome & ExtensFrac & FracNome End If Case 4 'Não lê a fração mas escreve como fração com um denominador de 100, 1000, 1000000... Ideal para moeda com fração de milésimo ExtensFrac = Num - Int(CDec(Num)) If ExtensFrac = 0 Then ExtensFrac = "nenhum/100" Else ExtensFrac = Format(ExtensFrac, "0.############") Signif = Len(ExtensFrac) - 2 If Signif > 3 And Signif <> 6 And Signif <> 9 And Signif <> 12 Then Signif = Int(CDec(Signif / 3)) * 3 + 3 If Signif > 1 Then ExtensFrac = (Num - Int(CDec(Num))) * 10 ^ Signif ExtensFrac = ExtensFrac & "/" & 10 ^ Signif Else ExtensFrac = (Num - Int(CDec(Num))) * 10 ^ 2 ExtensFrac = ExtensFrac & "/100" End If End If If ExtensInt = "" Then ExtensInt = "zero" 'Nome da unidade no singular ou plural UndNome = IIf(Int(CDec(Num)) = 1, UndNomeSing, UndNomePlur) fExtenso = ExtensInt & " " & UndNome & " e " & ExtensFrac End Select Select Case CaixaAlta Case 1 fExtenso = LCase(fExtenso) Case 2 fExtenso = UCase(Left(fExtenso, 1)) & Mid(fExtenso, 2) Case 3 fExtenso = StrConv(fExtenso, vbProperCase) fExtenso = MyReplace(fExtenso, " E ", " e ") Case 4 fExtenso = StrConv(fExtenso, vbUpperCase) End Select 'Preservar caixa alta de letra antes de ponto em UndNome Dim lPos As Long Dim lPos1 As Long Do While InStr(lPos + 1, UndNome, ".") > 1 lPos = InStr(lPos + 1, UndNome, ".") lPos1 = InStr(lPos1 + 1, fExtenso, ".") fExtenso = Left(fExtenso, lPos1 - 2) & Mid(UndNome, lPos - 1, 1) & Mid(fExtenso, lPos1) Loop End Function Private Function fExtensoInt(Num As Double, UndMasc As Boolean, UmMil As Boolean, VirgEntrMilh As Boolean) As String 'Gramática portuguesa: 'Regra Geral: Não se intercala a conjunção 'e' e nem vírgula entre posições de milhar. 'Exceção: Se a milhar posterior for menor que 100 ou for centena inteira (100,200,300...) 'Alguns gramáticos não aceitam essa exceção e outros já aceitam a vírgula. 'A variável ConjExc ativa/desativa a exceção 'A variável VirgEntrMilh usa vírgula entre milhares Dim NumText As String Dim Ce As String Dim Ma As String Dim Mõ As String Dim Bi As String Dim f As String Dim ConjExc As Boolean ConjExc = True If VirgEntrMilh Then ConjExc = False If Num = 0 Then fExtensoInt = "" Exit Function End If NumText = Format(Num, "000,000,000,000") '1º Posição de milhar, Centenas Ce = Mid(NumText, 13, 3) '2º Posição de milhar, Milhares Ma = Mid(NumText, 9, 3) '3º Posição de milhar, Milhões Mõ = Mid(NumText, 5, 3) '4º Posição de milhar, Bilhões Bi = Mid(NumText, 1, 3) f = fMilharText(Bi, UndMasc) & IIf(Bi > 0, IIf(Bi > 1, " bilhões", " bilhão"), "") f = f & IIf(VirgEntrMilh And Bi > 0 And Mõ > 0, ", ", IIf(Bi > 0 And Mõ > 0, " ", "")) f = f & IIf(ConjExc And Bi > 0 And Mõ > 0 And (Mõ < 100 Or Right(Mõ, 2) = "00"), "e ", "") f = f & fMilharText(Mõ, UndMasc) & IIf(Mõ > 0, IIf(Mõ > 1, " milhões", " milhão"), "") f = f & IIf(VirgEntrMilh And Bi + Mõ > 0 And Ma > 0, ", ", IIf(Bi + Mõ > 0 And Ma > 0, " ", "")) f = f & IIf(ConjExc And Bi + Mõ > 0 And Ma > 0 And (Ma < 100 Or Right(Ma, 2) = "00"), "e ", "") f = f & fMilharText(Ma, UndMasc) & IIf(Ma > 0, IIf(Ma > 1, " mil", " mil"), "") If Not UmMil Then If f = "um mil" Then f = "mil" 'Omitir 'um' em 'um mil' f = f & IIf(VirgEntrMilh And Bi + Mõ + Ma > 0 And Ce > 0, ", ", IIf(Bi + Mõ + Ma > 0 And Ce > 0, " ", "")) f = f & IIf(ConjExc And Bi + Mõ + Ma > 0 And Ce > 0 And (Ce < 100 Or Right(Ce, 2) = "00"), "e ", "") f = f & fMilharText(Ce, UndMasc) & IIf(Ce > 0, ",", "") f = IIf(Right(f, 1) = ",", Mid(f, 1, Len(f) - 1), f) f = IIf(Right(f, 2) = "ão", f & " de", f) f = IIf(Right(f, 3) = "ões", f & " de", f) fExtensoInt = f End Function Private Function fMilharText(NumText As String, UndMasc As Boolean) 'Gramática portuguesa: 'Regra Geral: Intercala-se a conjunção 'e' entre centenas, dezenas e unidades Dim UndText As String Dim DezenaText As String Dim CentenaText As String Const ConjDez_Un = " e " 'Conjunção entre Dezena e Unidade Const ConjCen_Dez = " e " 'Conjunção entre Centena e Unidade ' Unidade texto If Mid(NumText, 2, 1) <> "1" Then UndText = Choose(Mid(NumText, 3, 1) + 1, "", IIf(UndMasc, "um", "uma"), _ IIf(UndMasc, "dois", "duas"), "três", "quatro", "cinco", "seis", _ "sete", "oito", "nove") Else UndText = "" End If 'Dezena texto If Mid(NumText, 2, 1) <> "1" Then DezenaText = Choose(Mid(NumText, 2, 1) + 1, "", "dez", "vinte", _ "trinta", "quarenta", "cinqüenta", "sessenta", "setenta", _ "oitenta", "noventa") Else DezenaText = Choose(Mid(NumText, 3, 1) + 1, "dez", "onze", _ "doze", "treze", "quatorze", "quinze", "dezesseis", _ "dezessete", "dezoito", "dezenove") End If 'Centena texto If UndMasc Then CentenaText = Choose(Mid(NumText, 1, 1) + 1, "", "cento", "duzentos", _ "trezentos", "quatrocentos", "quinhentos", "seiscentos", _ "setecentos", "oitocentos", "novecentos") Else CentenaText = Choose(Mid(NumText, 1, 1) + 1, "", "cento", "duzentas", _ "trezentas", "quatrocentas", "quinhentas", "seiscentas", _ "setecentas", "oitocentas", "novecentas") End If If Mid(NumText, 1, 1) = "1" And Mid(NumText, 2, 2) = "00" Then CentenaText = "cem" 'Milhar texto fMilharText = CentenaText & IIf(Mid(NumText, 2, 2) * 1 > 0 And CentenaText <> "", ConjCen_Dez, "") _ & DezenaText & IIf(Mid(NumText, 2, 2) * 1 <= 19 Or Right(NumText, 1) = "0", "", ConjDez_Un) _ & UndText End Function Function Pluralizar(Sing As String) As String Dim e As String Dim IsLCase As Boolean IsLCase = Right(Sing, 1) = LCase(Right(Sing, 1)) 'Regra geral: Pluralizar = IIf(Sing = "", "", Sing & IIf(IsLCase, "s", "S")) 'Exceções: (Quase todas) ' Nomes terminados em al, el, ol, ul, il e = LCase(Right(Sing, 2)) If e = "al" Or e = "el" Or e = "ol" Or e = "ul" Or e = "il" Then Pluralizar = Left(Sing, Len(Sing) - 1) & IIf(IsLCase, "is", "IS") 'Nomes terminados em il If e = "il" Then Pluralizar = Left(Sing, Len(Sing) - 2) & IIf(IsLCase, "is", "IS") ' Nomes terminados em r, s, z e = LCase(Right(Sing, 1)) If e = "r" Or e = "s" Or e = "z" Then Pluralizar = Sing & IIf(IsLCase, "es", "ES") ' Nomes terminados em m If e = "m" Then Pluralizar = Left(Sing, Len(Sing) - 1) & IIf(IsLCase, "ns", "NS") ' Nomes terminados em x If e = "x" Then Pluralizar = Sing End Function Private Function MyReplace(vText As String, vTxtFind As String, vTxtRep As String) 'Word 6.0 VBA doesn't have Replace function Dim lPos As Long lPos = 1 - Len(vTxtRep) vStart: lPos = InStr(lPos + Len(vTxtRep), vText, vTxtFind) If lPos = 0 Or vTxtFind = "" Then MyReplace = vText Exit Function End If vText = Left(vText, lPos - 1) & vTxtRep & Right(vText, Len(vText) - lPos - Len(vTxtFind) + 1) GoTo vStart End Function