Rotina Em Extenso

[mizzu]

Alguém pode me fornecer a rotina do Visual Basic para imprimir

o valor em real em extenso.

grato.

e-mail: mizzu@jupiter.com.br

[Garcia]

Então cara... um dia eu peguei essa rotina na internet, nunca testei... dá uma olhada e diz se funciona.

Abraço

------------------------------------------------

Public Function Extenso(ByVal Valor As _

Double, ByVal MoedaPlural As _

String, ByVal MoedaSingular As _

String) As String

Dim StrValor As String, Negativo As Boolean

Dim Buf As String, Parcial As Integer

Dim Posicao As Integer, Unidades

Dim Dezenas, Centenas, PotenciasSingular

Dim PotenciasPlural

Negativo = (Valor < 0)

Valor = Abs(CDec(Valor))

If Valor Then

Unidades = Array(vbNullString, "Um", "Dois", _

"Três", "Quatro", "Cinco", _

"Seis", "Sete", "Oito", "Nove", _

"Dez", "Onze", "Doze", "Treze", _

"Quatorze", "Quinze", "Dezesseis", _

"Dezessete", "Dezoito", "Dezenove")

Dezenas = Array(vbNullString, vbNullString, _

"Vinte", "Trinta", "Quarenta", _

"Cinqüenta", "Sessenta", "Setenta", _

"Oitenta", "Noventa")

Centenas = Array(vbNullString, "Cento", _

"Duzentos", "Trezentos", _

"Quatrocentos", "Quinhentos", _

"Seiscentos", "Setecentos", _

"Oitocentos", "Novecentos")

PotenciasSingular = Array(vbNullString, " Mil", _

" Milhão", " Bilhão", _

" Trilhão", " Quatrilhão")

PotenciasPlural = Array(vbNullString, " Mil", _

" Milhões", " Bilhões", _

" Trilhões", " Quatrilhões")

StrValor = Left(Format(Valor, String(18, "0") & _

".000"), 18)

For Posicao = 1 To 18 Step 3

Parcial = Val(Mid(StrValor, Posicao, 3))

If Parcial Then

If Parcial = 1 Then

Buf = "Um" & PotenciasSingular((18 - _

Posicao) \ 3)

ElseIf Parcial = 100 Then

Buf = "Cem" & PotenciasSingular((18 - _

Posicao) \ 3)

Else

Buf = Centenas(Parcial \ 100)

Parcial = Parcial Mod 100

If Parcial <> 0 And Buf <> vbNullString Then

Buf = Buf & " e "

End If

If Parcial < 20 Then

Buf = Buf & Unidades(Parcial)

Else

Buf = Buf & Dezenas(Parcial \ 10)

Parcial = Parcial Mod 10

If Parcial <> 0 And Buf <> vbNullString Then

Buf = Buf & " e "

End If

Buf = Buf & Unidades(Parcial)

End If

Buf = Buf & PotenciasPlural((18 - Posicao) \ 3)

End If

If Buf <> vbNullString Then

If Extenso <> vbNullString Then

Parcial = Val(Mid(StrValor, Posicao, 3))

If Posicao = 16 And (Parcial < 100 Or _

(Parcial Mod 100) = 0) Then

Extenso = Extenso & " e "

Else

Extenso = Extenso & ", "

End If

End If

Extenso = Extenso & Buf

End If

End If

Next

If Extenso <> vbNullString Then

If Negativo Then

Extenso = "Menos " & Extenso

End If

If Int(Valor) = 1 Then

Extenso = Extenso & " " & MoedaSingular

Else

Extenso = Extenso & " " & MoedaPlural

End If

End If

Parcial = Int((Valor - Int(Valor)) * _

100 + 0.1)

If Parcial Then

Buf = Extenso(Parcial, "Centavos", _

"Centavo")

If Extenso <> vbNullString Then

Extenso = Extenso & " e "

End If

Extenso = Extenso & Buf

End If

End If

End Function

'P/ chamar a função:

Dim sRet As String

Dim dValor As Double

dValor = 1500.50

sRet = Extenso(dValor, "Reais", "Real")

MsgBox sRet

[Garcia]

Ficou um lixo essa rotina sem identação. Te mandei via email.

Não tem onde a gente enviar um arquivo ou postar um código (com identação) no site ?