Valor por extenso sem DLL

Moderador: Avelino Sampaio

GCorrea
Mensagens: 1
Registrado em: 10 Jun 2015, 14:28

Valor por extenso sem DLL

Mensagempor GCorrea » 10 Jun 2015, 15:44

PARA ESCREVER EM UM RELATÓRIO TIPO (PREENCHIMENTO DE CHEQUE), O VALOR POR EXTENSO SEM DLL

Código: Selecionar todos

Function Extensos(nValor) As String
On Error GoTo TrataErro

If IsNull(nValor) Or nValor > 999999999.99 Then
MsgBox "O valor é igual a zero ou maior que 999.999.999,99" & vbNewLine & _
"Impossível apresentar o valor por extenso", _
vbExclamation + vbOKOnly, "Verifique o valor"
GoTo Saida
End If

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 Left(strFinal, 1) = "u" Then
Extensos = "H" & Mid$(strFinal, 1)
Else
Extensos = UCase(Mid$(strFinal, 1, 1)) & Mid$(strFinal, 2)
End If

Dim aux As String * 250

aux = Trim(Extensos)
Extensos = "(" & Trim(aux) & ")"
Saida:
Exit Function

TrataErro:
MsgBox Err.Description, vbExclamation + vbOKOnly, "Erro: " & CStr(Err.Number)
Resume
Resume Saida
End Function


Depois coloque na origem do controle, que irá mostrar o valor por extenso:

=Extensos([SeuCampo])

Disable adblock

Precisamos do seu apoio. Faca uma doacao para o site atraves do Paypal.


Avatar do usuário
ahteixeira
Mensagens: 47
Registrado em: 07 Jun 2015, 18:51
Localização: Porto - Portugal

Re: Valor por extenso sem DLL

Mensagempor ahteixeira » 08 Jul 2015, 08:47

Olá, aproveito para partilhar o mesmo exemplo mas em Euros

Código: Selecionar todos

Option Compare Database
Option Explicit

Function ExtensoEur(nValor, Optional cortarFim As Boolean = False)
'Autoria..: Eng. Cesar Costa e Dalicio Guiguer Filho
'Linguagem: Access Basic
'Data.....: Fevereiro/1994

'Modificada: Wintceas Villaça Godois Jr.
'Linguagem.: VBA
'Data......: Outubro/1997

'Modificada: César Rocha
'Linguagem.: VBA
'Data......: Novembro/1997

'Modificada: Alvaro Teixeira
'Linguagem.: VBA
'Data......: Maio/2000 e Janeiro/2005


'Faz a validação do argumento
  If IsNull(nValor) Or nValor <= 0 Or nValor > 999999999.99 Then
    Exit Function
  End If


'Declara as variáveis da função
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

'Define matrizes com extensos parciais
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) = "catorze ": strUnid(15) = "quinze ": strUnid(16) = "dezasseis ": strUnid(17) = "dezassete ": strUnid(18) = "dezoito ": strUnid(19) = "dezanove "
Dim strDezena(9) As String
strDezena(1) = "dez ": strDezena(2) = "vinte ": strDezena(3) = "trinta ": strDezena(4) = "quarenta ": strDezena(5) = "cinquenta ": 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 "

'Divide o valor em vários grupos
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) 'cêntimo

    'Processa cada grupo
    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
       
        'If Right$(strParte, 1) = "1" And intContador = "2" Then
        If Right$(strParte, 1) = "1" And intContador = "2" And nValor >= 1000 And nValor < 2000 Then
                strTexto(intContador) = strTexto(intContador)
            Else
                strTexto(intContador) = strTexto(intContador) + strUnid(Right(strParte, 1))
            End If
        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, "cêntimo", "cêntimos")
    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 e ", "")
            End If
        End If
   
        If Val(strGrupo(4)) = 0 Then
            strFinal = strFinal + strTexto(3) + IIf(Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 1, "euro", "euros")
        Else
            strFinal = strFinal + strTexto(3) + IIf(Val(strGrupo(3)) <> 1, IIf(Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 1, "euro ", "euros "), "euro ")
        End If
       
        strFinal = strFinal + IIf(Val(strGrupo(4)) <> 0, "e " + strTexto(4) + IIf(Val(strGrupo(4)) = 1, "cêntimo", "cêntimos"), "")
    End If

    ExtensoEur = UCase(Mid$(strFinal, 1, 1)) + Mid$(strFinal, 2)
   
    'cortar no fim, exemplo:
    'Dez euros-X-X-X-X-X-X-X-X-X-X-X-X-X-X-X-X-X-X-X-X-X-X-X-X-X-X-X-
    If cortarFim Then
        Dim aux As String * 150
        aux = Trim(ExtensoEur)
        While Len(Trim(aux)) <> 150
            aux = Trim(aux) & "-X"
        Wend
        ExtensoEur = aux
    End If

End Function


Para chamar
=ExtensoEur([nomeCampoComValor])

Caso seja para cortar no fim:
=ExtensoEur([nomeCampoComValor],true)

Abraço
Você deve estar registrado e autenticado para ter acesso ao arquivo anexo.
Última edição por ahteixeira em 08 Jul 2015, 11:01, editado 1 vez no total.

Avatar do usuário
Avelino Sampaio
Mensagens: 2163
Registrado em: 04 Jun 2015, 18:27
Contato:

Re: Valor por extenso sem DLL

Mensagempor Avelino Sampaio » 08 Jul 2015, 09:14

Obrigado ahTeixeira
==================================================
Clique no link abaixo e veja um ótimo kit de ensino que tenho para você.
http://www.usandoaccess.com.br
==================================================

Avatar do usuário
ahteixeira
Mensagens: 47
Registrado em: 07 Jun 2015, 18:51
Localização: Porto - Portugal

Re: Valor por extenso sem DLL

Mensagempor ahteixeira » 08 Jul 2015, 11:03

Obrigado Mestre.
Actualizei código acima e incluí exemplo.
Abraço

Disable adblock

Precisamos do seu apoio. Faca uma doacao para o site atraves do Paypal.



Voltar para “Biblioteca de códigos VBA, API e VbScript”

Quem está online

Usuários neste fórum: Nenhum usuário registrado e 1 visitante