by Jmaster (1 Submission)
Category: Miscellaneous
Compatability: Visual Basic 5.0
Difficulty: Unknown Difficulty
Originally Published: Sat 9th November 2002
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Transforma em extenso qualquer valor (Translate a number into words in Portuguese)
VBcoders
=
' FUNÇÃO: Centena
' Recebe parte do número (entre 0 and 999) e transforma em texto
=
Function Centena(NumText)
Dim ct As String, X As Integer, TxtCentena As Integer
ct = "" 'Zera valor temporário da função
If val(NumText) > 0 Then
For X = 1 To Len(NumText) 'loop de 1 até 3
Select Case Len(NumText)
Case 3:
If val(NumText) > 99 Then
TxtCentena = val(Left(NumText, 1))
Select Case TxtCentena
Case 1
If Right(NumText, 2) = "00" Then
ct = "cem "
Else
ct = "cento "
End If
Case 2: ct = "duzentos "
Case 3: ct = "trezentos "
Case 4: ct = "quatrocentos "
Case 5: ct = "quinhentos "
Case 6: ct = "seiscentos "
Case 7: ct = "setecentos "
Case 8: ct = "oitocentos "
Case Else: ct = "novecentos "
End Select
' Trata a exceção: 'duzentos' e 'duzentos e'
ct = IIf(Right(NumText, 2) > "00", ct & "e ", Left(ct, Len(ct) - 1))
'If Right(NumText, 2) > "00" Then
'CT = CT & "e "
'Else
'CT = Left(CT, Len(CT) - 1)
'End If
End If
NumText = Right(NumText, 2)
Case 2:
ct = ct & Dezena(NumText)
NumText = ""
Case 1:
ct = Unidade(NumText)
Case Else
End Select
Next X
End If
Centena = ct 'Valor final da função
End Function
' FUNÇÃO: Dezena
' Recebe parte do número (entre 10 and 99) e transforma em texto
Function Dezena(TxtDezena)
Dim DZ As String
Dim Unid As Integer
DZ = "" 'anula o valor temporário da função
If val(Left(TxtDezena, 1)) = 1 Then ' Valor de 10 a 19
Select Case val(TxtDezena)
Case 10: DZ = "dez"
Case 11: DZ = "onze"
Case 12: DZ = "doze"
Case 13: DZ = "treze"
Case 14: DZ = "quatorze"
Case 15: DZ = "quinze"
Case 16: DZ = "dezesseis"
Case 17: DZ = "dezessete"
Case 18: DZ = "dezoito"
Case 19: DZ = "dezenove"
Case Else
End Select
Else ' Valor de 20 a 99
Select Case val(Left(TxtDezena, 1))
Case 2: DZ = "vinte "
Case 3: DZ = "trinta "
Case 4: DZ = "quarenta "
Case 5: DZ = "cinqüenta "
Case 6: DZ = "sessenta "
Case 7: DZ = "setenta "
Case 8: DZ = "oitenta "
Case 9: DZ = "noventa "
Case Else
End Select
Unid = val(Right(TxtDezena, 1))
If val(Left(TxtDezena, 1)) <> 0 Then
If Unid <> 0 Then
DZ = DZ & "e "
Else
DZ = Left(DZ, Len(DZ) - 1)
End If
End If
'If Val(Left(TxtDezena, 1)) <> 0 And Unid <> 0 Then DZ = DZ & "e "
DZ = DZ & Unidade(Right(TxtDezena, 1)) 'Junta unidades
End If
Dezena = DZ ' Valor final da função
End Function
' FUNÇÃO: Extenso
' OBJETO: Recebe um número e o transforma em texto
' Função principal de um conjunto de quatro rotinas
Function extenso(NumValor As Currency) As String
'--- Declaração de variáveis locais
ReDim Bloco(9) As String 'Matriz: string de 1 bloco de 3 dígitos
ReDim TxtBloco(9) As String 'Matriz: texto para mil, milhão, sing.
ReDim TxtBlocoP(9) As String 'Matriz: texto para mil, milhão, plural
ReDim Acumula(9) As String
Dim CmpCruz As Integer 'Compr. da string do valor (parte inteira)
Dim ext As String, TxtValor As String
Dim PosPtoDec As Integer, Cruzeiros As String
Dim Cents As Variant, TotalBlocos As Integer
Dim n As Integer, RCmpCruz As Integer
Dim ConvBloco As String, TotalCents As String
Dim PrimCruz As String, TxtInt$
'Dim ContaBloco As Integer
'Encerra função se valor é zero ou branco
If NumValor = 0 Or NumValor = Null Then Exit Function
' Define os nomes para mil, milhão, bilhão, etc.,
' no singular e no plural
TxtBloco(2) = " mil, "
TxtBloco(3) = " milhão, "
TxtBloco(4) = " bilhão, "
TxtBloco(5) = " trilhão, "
TxtBlocoP(2) = " mil e "
TxtBlocoP(3) = " milhões, "
TxtBlocoP(4) = " bilhões, "
TxtBlocoP(5) = " trilhões, "
ext = "" 'Valor temporário da função.
TxtValor = Trim(Str(NumValor)) 'String do valor a converter.
PosPtoDec = InStr(Trim(TxtValor), ".") 'Posição do ponto decimal; 0 se não existir
Cruzeiros = Trim(Left(TxtValor, IIf(PosPtoDec = 0, Len(TxtValor), PosPtoDec - 1)))
PrimCruz$ = Cruzeiros 'Reserva o valor de Cruzeiros
CmpCruz = Len(Cruzeiros)
Cents = Trim(Right(TxtValor, IIf(PosPtoDec = 0, 0, Abs(PosPtoDec - Len(TxtValor)))))
'Ajusta valor de centavos ao nível de aproximação do sistema
'Para 4, 3 e 1 decimal
If Len(Cents) = 4 Then
If val(Right(Cents, 2)) > 50 Then
Cents = Format(val(Cents / 100) + 1, "00")
Else
Cents = Left(Cents, 2)
End If
End If
If Len(Cents) = 3 Then
If val(Right(Cents, 1)) > 5 Then
Cents = Format(val(Cents / 10) + 0.1, "00")
Else
Cents = Left(Cents, 2)
End If
End If
If Len(Cents) = 1 Then
Cents = Cents & "0"
End If
If (CmpCruz Mod 3) = 0 Then
TotalBlocos = (CmpCruz \ 3)
Else
TotalBlocos = (CmpCruz \ 3) + 1
End If
n% = 1
RCmpCruz = CmpCruz 'RCmpCruz reserva valor de CmpCruz
Do While CmpCruz > 0
Bloco(n%) = IIf(CmpCruz > 3, Right(Cruzeiros, 3), Trim(Cruzeiros))
Cruzeiros = IIf(CmpCruz > 3, Left(Cruzeiros, (IIf(CmpCruz < 3, 3, CmpCruz)) - 3), "")
CmpCruz = Len(Cruzeiros)
n% = n% + 1
Loop
' Preenche matriz Acumula, que será usada no
' tratamento de exceções
Acumula(1) = Bloco(1)
For n% = 2 To TotalBlocos
Acumula(n%) = Bloco(n%) + Acumula(n% - 1)
Next n%
For n% = TotalBlocos To 1 Step -1 'Varre a matriz Bloco
' Controla plural: "milhões", "bilhões" etc.
If n% > 2 And val(Bloco(n%)) > 1 Then TxtBloco(n%) = TxtBlocoP(n%)
' Controla "mil", "mil e"
If n% = 2 Then
If val(Bloco(1)) > 0 Then
If (Right(Bloco(1), 2) = "00" Or val(Bloco(1)) < 100) And val(Cents) = 0 Then TxtBloco(n%) = TxtBlocoP(n%)
If val(Bloco(n%)) = 0 Then TxtBloco(n%) = "e"
End If
If val(Bloco(1)) = 0 Then TxtBloco(n%) = RTrim(TxtBloco(n%))
End If
' Adiciona "de" e "e" a "milhões", "bilhões"
If n% > 2 Then
If val(Acumula(n% - 1)) = 0 Then
TxtBloco(n%) = TxtBloco(n%) & "de"
Else
If val(Cents) = 0 Then
If val(Acumula(2)) = 0 Then
If val(Bloco(3)) > 0 And val(Bloco(4)) > 0 Then TxtBloco(4) = TxtBloco(4) & "e "
If val(Bloco(3)) > 0 And val(Bloco(4)) = 0 Then TxtBloco(5) = TxtBloco(5) & "e "
If val(Bloco(3)) = 0 And val(Bloco(4)) > 0 Then TxtBloco(5) = TxtBloco(5) & "e "
End If
If val(Bloco(2)) > 0 And val(Bloco(1)) = 0 Then
If Right(Bloco(2), 2) = "00" Or val(Bloco(2)) < 100 Then
If val(Bloco(3)) > 0 Then TxtBloco(3) = TxtBloco(3) & "e "
If val(Bloco(3)) = 0 And val(Bloco(4)) > 0 Then TxtBloco(4) = TxtBloco(4) & "e "
If val(Bloco(3)) = 0 And val(Bloco(4)) = 0 Then TxtBloco(5) = TxtBloco(5) & "e "
End If
End If
If val(Bloco(2)) = 0 And val(Bloco(1)) > 0 Then
If Right(Bloco(1), 2) = "00" Or val(Bloco(1)) < 100 Then
If val(Bloco(3)) > 0 Then TxtBloco(3) = TxtBloco(3) & "e "
If val(Bloco(3)) = 0 And val(Bloco(4)) > 0 Then TxtBloco(4) = TxtBloco(4) & "e "
If val(Bloco(3)) = 0 And val(Bloco(4)) = 0 Then TxtBloco(5) = TxtBloco(5) & "e "
End If
End If
End If
End If
End If
ConvBloco = Centena(Bloco(n%)) 'Converte 1 bloco de 3 dígitos
ext = ext & ConvBloco 'Concatena ao valor temporário da função
If ConvBloco <> "" Then ext = ext & TxtBloco(n%)
Next n%
TotalCents = Dezena(Cents) 'Converte centavos para texto
If Int(NumValor) = 0 Then ext = ext & TotalCents & IIf(val(Cents) > 1, " centavos", " centavo")
If Int(NumValor) = 1 Then
If val(Cents) = 0 Then
ext = ext & " real"
Else
ext = ext & " real e " & TotalCents & IIf(val(Cents) > 1, " centavos", " centavo")
End If
End If
If Int(NumValor) > 1 Then
If val(Cents) = 0 Then
ext = ext & " reais"
Else
ext = ext & " reais e " & IIf(val(Cents) > 1, TotalCents & " centavos", TotalCents & " centavo")
End If
End If
' Valor final da função: entre parênteses
extenso = "(" + ext + ")"
End Function 'Finaliza função; retorna o valor por extenso
' FUNÇÃO: Unidade
' Recebe parte do número (entre 1 e 9) e transforma em texto
Function Unidade(TxtUnidade)
' Atribui uma palavra a números de 1 dígito
Select Case val(TxtUnidade)
Case 1: Unidade = "um"
Case 2: Unidade = "dois"
Case 3: Unidade = "três"
Case 4: Unidade = "quatro"
Case 5: Unidade = "cinco"
Case 6: Unidade = "seis"
Case 7: Unidade = "sete"
Case 8: Unidade = "oito"
Case 9: Unidade = "nove"
Case Else: Unidade = ""
End Select
End Function
No comments have been posted about Transforma em extenso qualquer valor (Translate a number into words in Portuguese). Why not be the first to post a comment about Transforma em extenso qualquer valor (Translate a number into words in Portuguese).