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 : 4653
    Registrado : 15/03/2013

    Valor por extenso em Euros (EUR) sem DLL

    Mensagem  ahteixeira em Qua 08 Jul 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 85 vez(es)

      Data/hora atual: Sex 15 Dez 2017, 12:19