Extenso

[bEbEr]

Com faz pra pegar o valor de um campo e escreve por extenso o número?

Ex: Campo1 = 60

Campo2 = Sessenta reais

vlw

[Lisandro Oliveira]

Com faz pra pegar o valor de um campo e escreve por extenso o número?

Ex: Campo1 = 60

Campo2 = Sessenta reais

vlw

Vá em ferramentas / Macro / Editor do Visual Basic

Agora vá em inserir / módulo e cole tudo isso lá.

Depois de colar, coloque em uma célula a função:

=fextenso(A1;1;"Real")

Na célula A1 coloque um valor.

beleza??

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) As String

Dim ExtensInt As String

Dim ExtensFrac As String

Dim UndNome As String

Dim FracNome As String

Dim Signif As String

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 Not Mid(UndNomeSing, 2, 1) = UCase(Mid(UndNomeSing, 2, 1)) Then UndNomeSing = LCase(UndNomeSing)

If UndNomePlur <> "" Then

If Not Mid(UndNomePlur, 2, 1) = UCase(Mid(UndNomePlur, 2, 1)) Then UndNomePlur = LCase(UndNomePlur)

Else

UndNomePlur = IIf(UndNomeSing = "", "", Pluralizar(UndNomeSing))

'Se a função Pluralizar falhar palavras estrangeiras ou em exceções

'portuguesas, deve ser usado o argumento UndNomePlur.

End If

'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 'Lê fração em centavo. 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, " centavo", " 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

End Select

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

'Regra geral:

Pluralizar = IIf(Sing = "", "", Sing & "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) & "is"

'Nomes terminados em il

If e = "il" Then Pluralizar = Left(Sing, Len(Sing) - 2) & "is"

' Nomes terminados em r, s, z

e = LCase(Right(Sing, 1))

If e = "r" Or e = "s" Or e = "z" Then Pluralizar = Sing & "es"

' Nomes terminados em m

If e = "m" Then Pluralizar = Left(Sing, Len(Sing) - 1) & "ns"

' Nomes terminados em m

If e = "x" Then Pluralizar = Sing

End Function