MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

Obrigado

Administração do MaximoAccess

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access

    Valor por extenso em Euros (EUR) sem DLL

    Compartilhe
    avatar
    ahteixeira
    Moderador Global
    Moderador Global

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 5293
    Registrado : 15/03/2013

    Valor por extenso em Euros (EUR) sem DLL

    Mensagem  ahteixeira em 8/7/2015, 12:09

    Olá, apesar de já existir vários exemplos, partilho esta versão em Euros.

    Código:
    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
    Anexos
    ExtensoEur.zip
    Você não tem permissão para fazer download dos arquivos anexados.
    (26 Kb) Baixado 107 vez(es)
    avatar
    ahteixeira
    Moderador Global
    Moderador Global

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 5293
    Registrado : 15/03/2013

    Re: Valor por extenso em Euros (EUR) sem DLL

    Mensagem  ahteixeira em 19/1/2018, 14:50

    Olá a todos,

    A propósito de questão de colega [Você precisa estar registrado e conectado para ver este link.] , partilho versão adaptada para o pretendido.
    Faz a descrição de numeros com mais de duas casas decimais e foi retirado o descritivo Euro(s)/Cêntimo(s).

    Código utilizado:
    Código:
    Option Compare Database
    Option Explicit

    Function geraExtenso(nValor)
    ' Autor ..: Alvaro Teixeira (ahteixeira)
    ' Data ...: 19-01-2018
    ' Para ...: MaximoAccess.com
    ' Obs ....: Requer função ExtensoVDec
    '           Gera o entenso da parte inteira adiciona o texto "vírgula"
    '            e adiciona o extenso da parte decimal
    Dim xValor As Double
    Dim arrValor() As String
    Dim tmpExtenso As String

        If Not IsNumeric(nValor) Then Exit Function
        
        xValor = nValor
        
        'Verifica se tem separador decimal (em alguns formatos pode ser o ponto
        If InStr(xValor, ",") > 0 Then
            arrValor = Split(nValor, ",")
            tmpExtenso = ExtensoVDec(arrValor(0))
            tmpExtenso = tmpExtenso & "vírgula " & LCase(ExtensoVDec(arrValor(1)))
        Else
            tmpExtenso = ExtensoVDec(xValor)
        End If

    geraExtenso = tmpExtenso

    End Function

    Function ExtensoVDec(nValor)
    '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
    'Observação: Janeiro/2018 - Adaptado para usar com função geraExtenso


    '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, "", "")
            Else
                strFinal = strFinal + strTexto(3) + IIf(Val(strGrupo(3)) <> 1, IIf(Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 1, "", ""), "")
            End If
            
            strFinal = strFinal + IIf(Val(strGrupo(4)) <> 0, "e " + strTexto(4) + IIf(Val(strGrupo(4)) = 1, "", ""), "")
        End If

        ExtensoVDec = UCase(Mid$(strFinal, 1, 1)) + Mid$(strFinal, 2)

    End Function

    Abraço e Bons estudos com o MaximoAccess Wink

      Data/hora atual: 20/7/2018, 13:17