MaximoAccess

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

https://www.maximoaccess.com/t48-regras-do-forum

Obrigado

Administração


Participe do fórum, é rápido e fácil

MaximoAccess

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

https://www.maximoaccess.com/t48-regras-do-forum

Obrigado

Administração

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

2 participantes

    [Resolvido]Sobre a Função "TiraAcentos" do JPaulo

    Walter
    Walter
    Avançado
    Avançado


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 371
    Registrado : 17/04/2011

    [Resolvido]Sobre a Função "TiraAcentos" do JPaulo Empty [Resolvido]Sobre a Função "TiraAcentos" do JPaulo

    Mensagem  Walter 17/12/2021, 22:40

    Boa noite.

    No meu campo "NomePaciente" coloquei o código abaixo para converter todas as palavras para MAIUSCULAS, e funcionou legal.

    Private Sub NomePaciente_AfterUpdate()
    Dim strCaractere As String
    strCaractere = Chr(KeyAscii) ' Converte valor ANSI em seqüência de caracteres.
    KeyAscii = Asc(UCase(strCaractere)) ' Converte caractere para maiúsculo e, depois, em valor ANSI.
    End Sub


    Porém eu quero melhorar e retirar os acentos e cedilhas das palavras e por isso chamei a Função criada pelo JPaulo "DLTiraAcento", ela faz isso mas converte as letras para minúsculas, exceto as primeiras letras de cada palavra.

    Gostaria que a função retirasse os acentos e mantivesse as letras em MAIÚSCULO... O que devo modificar nela?
    Alguém tem outro código, ou função, que faça isso?

    Obrigado.

    Abaixo a Função do JPaulo.

    Public Function DLTiraAcentos(ByVal strOriginal As String)
    'By JPaulo @ 2009
    Dim strToReturn As String
    strToReturn = ""

    Dim I As Integer
    For I = 1 To Len(strOriginal)
    strToReturn = strToReturn & DLTiraAcentos_GetCorrectChar(Mid$(strOriginal, I, 1))
    Next I

    DLTiraAcentos = StrConv(strToReturn, 3)

    End Function
    Public Function DLTiraAcentos_GetCorrectChar(ByVal strChar As String) As String
    Dim LetrasComAcentos As String
    Dim LetrasSemAcentos As String
    LetrasComAcentos = "ÁÍÓÚÉÄÏÖÜËÀÌÒÙÈÃÕÂÎÔÛÊáíóúéäïöüëàìòùèãõâîôûêÇç"
    LetrasSemAcentos = "AIOUEAIOUEAIOUEAOAIOUEaioueaioueaioueaoaioueCc"
    Dim I As Integer
    For I = 1 To Len(LetrasComAcentos)
    If strChar = Mid$(LetrasComAcentos, I, 1) Then
    DLTiraAcentos_GetCorrectChar = Mid$(LetrasSemAcentos, I, 1)
    Exit Function
    End If
    Next

    DLTiraAcentos_GetCorrectChar = strChar
    End Function


    .................................................................................
    "A verdade é filha do tempo, e não da autoridade!"
    Walter
    Walter
    Avançado
    Avançado


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 371
    Registrado : 17/04/2011

    [Resolvido]Sobre a Função "TiraAcentos" do JPaulo Empty Re: [Resolvido]Sobre a Função "TiraAcentos" do JPaulo

    Mensagem  Walter 18/12/2021, 09:58

    Olá.

    Achei a resposta no próprio forum...

    Basta substituir UM NÚMERO em uma das linhas...

    Veja o Código como fica:

    '-------------------------------------------------------------
    Public Function DLTiraAcentos(ByVal strOriginal As String)
    'By JPaulo @ 2009
    Dim strToReturn As String
    strToReturn = ""

    Dim I As Integer
    For I = 1 To Len(strOriginal)
    strToReturn = strToReturn & DLTiraAcentos_GetCorrectChar(Mid$(strOriginal, I, 1))
    Next I

    ' Substituir essa linha abaixo, pela de baixo, em vermelho:

    'DLTiraAcentos = StrConv(strToReturn, 3) ' O número 3 faz com quê as primeiras letras de cada palavra fiquem em Maiúsculo e as demais fiquem em minúsculo.
    DLTiraAcentos = StrConv(strToReturn, 1) ' O número 1 faz tudo ficar MAIÚSCULO, do jeito que eu quero.
    'DLTiraAcentos = StrConv(strToReturn, 2) ' Essa, com o número 2, faz TUDO ficar em minúsculo.


    End Function
    Public Function DLTiraAcentos_GetCorrectChar(ByVal strChar As String) As String
    Dim LetrasComAcentos As String
    Dim LetrasSemAcentos As String
    LetrasComAcentos = "ÁÍÓÚÉÄÏÖÜËÀÌÒÙÈÃÕÂÎÔÛÊáíóúéäïöüëàìòùèãõâîôûêÇç"
    LetrasSemAcentos = "AIOUEAIOUEAIOUEAOAIOUEaioueaioueaioueaoaioueCc"
    Dim I As Integer
    For I = 1 To Len(LetrasComAcentos)
    If strChar = Mid$(LetrasComAcentos, I, 1) Then
    DLTiraAcentos_GetCorrectChar = Mid$(LetrasSemAcentos, I, 1)
    Exit Function
    End If
    Next

    DLTiraAcentos_GetCorrectChar = strChar
    End Function


    .................................................................................
    "A verdade é filha do tempo, e não da autoridade!"
    JPaulo
    JPaulo
    Moderador
    Moderador


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 10765
    Registrado : 04/11/2009

    [Resolvido]Sobre a Função "TiraAcentos" do JPaulo Empty Re: [Resolvido]Sobre a Função "TiraAcentos" do JPaulo

    Mensagem  JPaulo 20/12/2021, 11:45

    [Resolvido]Sobre a Função "TiraAcentos" do JPaulo 1f44d


    .................................................................................
    Contribua com o maximoaccess nos links abaixo, ajude a melhorar este que é o seu site na NET.

    Pay-Pal R$ Aqui
    Pay-Pal € Aqui

    Ou ainda: Aqui (Novo)

    Sucesso e Bons Estudos
    Success and Good Studies

    [Resolvido]Sobre a Função "TiraAcentos" do JPaulo Folder_announce_new Utilize o Sistema de Busca do Fórum...
    [Resolvido]Sobre a Função "TiraAcentos" do JPaulo Folder_announce_new 102 Códigos VBA Gratuitos...
    [Resolvido]Sobre a Função "TiraAcentos" do JPaulo Folder_announce_new Instruções SQL como utilizar...

      Data/hora atual: 25/9/2022, 15:34