Valor por extenso em Euros (EUR) sem DLL

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

Olá a todos,

A propósito de questão de colega neste tópico , 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