domingo, 28 de fevereiro de 2021
DVD
ConteÚdo
DOWNLOADS
Interação
dicas aleatórias
Dica #35
Critérios
Publicado: 11/12/2004

Artigos

Rotinas para escrever números por extenso

Vou usar o código por Extenso mas não pude indicar Hum mil Reais (com o H). pois não se trata de cheque mas de relatório é me foi pedido para indicar obedecendo a gramática, ou seja, Mil reais, dois mil reais, três mil reais ....................

Por: Osmar Jr (osmarjr@ativoaccess.com.br)
Publicado: 08/10/2006  Visitas: 3064
Dificuldade: Intermediário

Indicação de Artigo  Imprimir

Function ExtensoHum(nValor As String, Optional Hum As Boolean = True, Optional UmMil As Boolean = True) As String
'----------------------------------------------------------- ----------------------------
' Procedimento : ExtensoHum
' Data/Hora : 05/10/06 22:33
' Autor : OsmarJr
' Propósito : Função de extenso mais completa
' ; nValor - recebe o valor a ser convertido
' ; Hum - indica se o um mil deve ser escrito Hum mil ou Um mil (padrão Hum mil)
' ; UmMil - indica se deve ser escrito Um mil ou Mil (padrão Um mil)
'----------------------------------------------------------- ----------------------------
'
On Error GoTo ExtensoHum_Erro
If IsNull(nValor) Or CCur(nValor) > 999999999.99 Then Exit Function
Dim intContador As Integer
Dim intTamanho As Integer
Dim strValor As String
Dim strParte As String
Dim strFinal As String
Dim strGrupo(4) As String
Dim strTexto(4) As String
Dim strUnid(19) As String
strUnid(1) = "um "
strUnid(2) = "dois "
strUnid(3) = "três "
strUnid(4) = "quatro "
strUnid(5) = "cinco "
strUnid(6) = "seis "
strUnid(7) = "sete "
strUnid(8) = "oito "
strUnid(9) = "nove "
strUnid(10) = "dez "
strUnid(11) = "onze "
strUnid(12) = "doze "
strUnid(13) = "treze "
strUnid(14) = "quatorze "
strUnid(15) = "quinze "
strUnid(16) = "dezesseis "
strUnid(17) = "dezessete "
strUnid(18) = "dezoito "
strUnid(19) = "dezenove "
Dim strDezena(9) As String
strDezena(1) = "dez "
strDezena(2) = "vinte "
strDezena(3) = "trinta "
strDezena(4) = "quarenta "
strDezena(5) = "cinqüenta "
strDezena(6) = "sessenta "
strDezena(7) = "setenta "
strDezena(8) = "oitenta "
strDezena(9) = "noventa "
Dim strCentena(9) As String
strCentena(1) = "cento "
strCentena(2) = "duzentos "
strCentena(3) = "trezentos "
strCentena(4) = "quatrocentos "
strCentena(5) = "quinhentos "
strCentena(6) = "seiscentos "
strCentena(7) = "setecentos "
strCentena(8) = "oitocentos "
strCentena(9) = "novecentos "
strValor = Format$(nValor, "0000000000.00")
strGrupo(1) = Mid$(strValor, 2, 3) 'Milhão
strGrupo(2) = Mid$(strValor, 5, 3) 'Milhar
strGrupo(3) = Mid$(strValor, 8, 3) 'Centena
strGrupo(4) = "0" + Mid$(strValor, 12, 2) 'Centavo
For intContador = 1 To 4
strParte = strGrupo(intContador)
intTamanho = Switch(Val(strParte) < 10, 1, Val(strParte) < 100, 2, Val(strParte) < 1000, 3)
If intTamanho = 3 Then
If Right$(strParte, 2) <> "00" Then
strTexto(intContador) = strTexto(intContador) + strCentena(Left(strParte, 1)) + "e "
intTamanho = 2
Else
strTexto(intContador) = strTexto(intContador) + IIf(Left$(strParte, 1) = "1", "cem ", strCentena(Left(strParte, 1)))
End If
End If
If intTamanho = 2 Then
If Val(Right(strParte, 2)) < 20 Then
strTexto(intContador) = strTexto(intContador) + strUnid(Right(strParte, 2))
Else
strTexto(intContador) = strTexto(intContador) + strDezena(Mid(strParte, 2, 1))
If Right$(strParte, 1) <> "0" Then
strTexto(intContador) = strTexto(intContador) + "e "
intTamanho = 1
End If
End If
End If
If intTamanho = 1 Then
strTexto(intContador) = strTexto(intContador) + strUnid(Right(strParte, 1))
End If
Next intContador
'Gera o formato final do texto
If Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strTexto(4) + IIf(Val(strGrupo(4)) = 1, "centavo", "centavos")
Else
strFinal = ""
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões de ", "milhão de "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões e ", "milhão e "), "")
End If
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões e ", "milhão e "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
End If
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões de ", "milhão de "), "")
End If
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
End If
If Val(strGrupo(3)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil ", "")
Else
If Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil e ", "")
Else
strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil, ", "")
End If
End If
If Val(strGrupo(4)) = 0 Then
strFinal = strFinal + strTexto(3) + IIf(Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 1, "real ", "reais ")
Else
strFinal = strFinal + strTexto(3) + IIf(Val(strGrupo(3)) <> 1, IIf(Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 1, "real ", "reais "), "real ")
End If
strFinal = strFinal + IIf(Val(strGrupo(4)) <> 0, "e " + strTexto(4) + IIf(Val(strGrupo(4)) = 1, "centavo", "centavos"), "")
End If
If Hum Then
If Left(strFinal, 7) = "um mil," Then
strFinal = "H" & strFinal
End If
End If
If Hum And Not UmMil Then
If Left(strFinal, 8) = "hum mil," Then
strFinal = "Mil e " & Right(strFinal, Len(strFinal) - 8)
End If
End If
If Not Hum And Not UmMil Then
If Left(strFinal, 7) = "um mil," Then
strFinal = "Mil e " & Right(strFinal, Len(strFinal) - 7)
End If
End If

ExtensoHum = UCase(Mid$(strFinal, 1, 1)) & Mid$(strFinal, 2)
ExtensoHum = Trim(ExtensoHum)
Saida:
Exit Function
ExtensoHum_Erro:
MsgBox "Erro: " & vbCrLf & vbCrLf & Err.Description & vbCrLf & " no procedimento ExtensoHum", vbExclamation + vbOKOnly, "Erro: " & CStr(Err.Number)
Resume Saida
End Function
=============================================================
Exemplos:

Usando como exemplo o valor 1234,56:


?extensohum("1234,56", false, true)
Um mil, duzentos e trinta e quatro reais e cinqüenta e seis centavos


?extensohum("1234,56", false, false)
Mil e duzentos e trinta e quatro reais e cinqüenta e seis centavos


?extensohum("1234,56", true, false)
Mil e duzentos e trinta e quatro reais e cinqüenta e seis centavos


?extensohum("1234,56")
Hum mil, duzentos e trinta e quatro reais e cinqüenta e seis centavos

Links relacionados:
http://

Artigos relacionados:
  Nenhum artigo relacionado



 

   Copyright © Ativo Access 2003 - 2021- Todos os direitos reservados   Política de Privacidade | Fale conosco