MaximoAccess

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

Obrigado

Administração do MaximoAccess

MaximoAccess

Gostaria de reagir a esta mensagem? Crie uma conta em poucos cliques ou inicie sessão para continuar.

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

    [Resolvido]Valor Por Extenso em um Formulário

    avatar
    Bessa_SP
    Avançado
    Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 219
    Registrado : 07/11/2013

    [Resolvido]Valor Por Extenso em um Formulário Empty [Resolvido]Valor Por Extenso em um Formulário

    Mensagem  Bessa_SP em 22/5/2019, 12:52

    Boa dia Senhores.
    Por gentileza tenho um formulário de lançamento de fatura, aonde tenho um campo ValorFatura e outro ValorPorExtenso, abaixo segue o código de um módulo deixado pelo Professor Gilberlânio Rocha, copiei o mesmo criei o módulo e na caixa de texto txt_ValorFatura no evento após atualizar coloquei esse módulo para assim que seja colocado o valor numérico seja preenchido a caixa de texto txt_ValorPorExtenso com o valor por extenso.
    Bem funcionou, só que não do jeito que necessito, pois se o valor numérico for por Exemplo: R$ 100,00 , o valor por extenso sai da seguinte forma: Cem Reais -x-x-x-x-x-x-x-x-x-x-x-x, e ai tem que se apagar esses "-x", já tentei tirar isso do módulo mais quando altero o formulário trava, alguém pode me ajudar.... Abaixo o código do módulo...

    Obrigado!!!!

    Código:
    Function Extenso(nValor As String) As String
    '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

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

    '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) = "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 "

    '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) 'Centavo

    '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
    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
    Extenso = "H" & Mid$(strFinal, 1)
    Else
    Extenso = UCase(Mid$(strFinal, 1, 1)) & Mid$(strFinal, 2)
    End If
    Dim aux As String * 150
    aux = Trim(Extenso) ' e alterar esta linha para trim(Extenso)
    While Len(Trim(aux)) <> 150
    aux = Trim(aux) & "-x"
    Wend
    Extenso = aux

    End Function
    Silvio
    Silvio
    Developer
    Developer

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 4624
    Registrado : 20/04/2011

    [Resolvido]Valor Por Extenso em um Formulário Empty Re: [Resolvido]Valor Por Extenso em um Formulário

    Mensagem  Silvio em 22/5/2019, 12:55

    Bom dia...

    Sem conhecer bem o código eu creio que retirando

    Dim aux As String * 150
    aux = Trim(Extenso) ' e alterar esta linha para trim(Extenso)
    While Len(Trim(aux)) <> 150
    aux = Trim(aux) & "-x"
    Wend
    Extenso = aux



    Talvez possa funfar. Pois o que eu entendi, a função acima faz o preenchimento do " -x "


    .................................................................................
    Caso tenha resolvido a tua duvida, coloque o tópico como resolvido.
    www.maximoaccess.com/t860-resolucao-de-topicos

    "Quase tudo é possível quando se tem determinação e força de vontade. Não desista tão rápido."
    ahteixeira
    ahteixeira
    Moderador Global
    Moderador Global

    Respeito às Regras 100%

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

    [Resolvido]Valor Por Extenso em um Formulário Empty Re: [Resolvido]Valor Por Extenso em um Formulário

    Mensagem  ahteixeira em 22/5/2019, 13:00

    Olá, estou no celular.

    Mas comente estas linhas:
    Código:
    While Len(Trim(aux)) <> 150
    aux = Trim(aux) & "-x"
    Wend

    Ou seja, fica assim:
    Código:
    'While Len(Trim(aux)) <> 150
    'aux = Trim(aux) & "-x"
    'Wend

    e teste.

    Abraço
    ahteixeira
    ahteixeira
    Moderador Global
    Moderador Global

    Respeito às Regras 100%

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

    [Resolvido]Valor Por Extenso em um Formulário Empty Re: [Resolvido]Valor Por Extenso em um Formulário

    Mensagem  ahteixeira em 22/5/2019, 13:03

    Olá a todos,

    Silvio, ao mesmo tempo. Wink

    Ficamos aguardar retorno do colega.

    Abraço
    avatar
    Bessa_SP
    Avançado
    Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 219
    Registrado : 07/11/2013

    [Resolvido]Valor Por Extenso em um Formulário Empty Valor Por Extenso em um Formulário

    Mensagem  Bessa_SP em 22/5/2019, 13:04

    Amigo Ah Teixeira

    Obrigado pela ajuda, mais funcionou o que o Amigo Silvio me passou, obrigado....
    Silvio
    Silvio
    Developer
    Developer

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 4624
    Registrado : 20/04/2011

    [Resolvido]Valor Por Extenso em um Formulário Empty Re: [Resolvido]Valor Por Extenso em um Formulário

    Mensagem  Silvio em 22/5/2019, 13:20

    Alvaro estamos ai...

    Bessa se resolveu, maravilha.
    ahteixeira
    ahteixeira
    Moderador Global
    Moderador Global

    Respeito às Regras 100%

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

    [Resolvido]Valor Por Extenso em um Formulário Empty Re: [Resolvido]Valor Por Extenso em um Formulário

    Mensagem  ahteixeira em 22/5/2019, 13:39

    cheers

      Data/hora atual: 24/10/2020, 02:04