[Resolvido]Retira Acentos

Boa tarde JPaulo
Estou a tentar aplicar esta sua função num campo depois de actualizar, mas acontece o seguinte.
A eliminação dos acentos acontece.

Mas ao eliminar Por exemplo o acento de "Magalhães" a função muda para "MagalhAes".

Outro exemplo "Acácio" muda para "AcAcio"

Será que da para corrigir isto ?

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 = strToReturn

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

Obrigado

Ola Assis;

Esse código tinha essa intensão, dar destaque à letra que tinha a acentuação, mas se prefer em pequena altere a linha em azul;

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

Boa tarde Assis .... outra opção:
eu uso esta rotina e funciona muito bem

Function TiraAcento(Palavra)
'Autor desconhecido .... se alguem souber favor me informar

CAcento = "àáâãäèéêëìíîïòóôõöùúûüÀÁÂÃÄÈÉÊËÌÍÎÒÓÔÕÖÙÚÛÜçÇñÑ"
SAcento = "aaaaaeeeeiiiiooooouuuuAAAAAEEEEIIIOOOOOUUUUcCnN"
Texto = ""
If Palavra <> "" Then
For X = 1 To Len(Palavra)
Letra = Mid(Palavra, X, 1)
Pos_Acento = InStr(CAcento, Letra)
If Pos_Acento > 0 Then
Letra = Mid(SAcento, Pos_Acento, 1)
End If
Texto = Texto & Letra
Next
TiraAcento = Texto
End If
End Function

Function VerificaPalavra(atributo)

Dim i
Dim id
Dim Auxiliar
Dim Resultado

Auxiliar = Split(atributo, " ", -1, vbBinaryCompare)

For i = LBound(Auxiliar) To UBound(Auxiliar)
Resultado = Resultado & " " & TiraAcento(Auxiliar(i))
Next

VerificaPalavra = Trim(Resultado)

End Function


Para usá-la:
Private Sub SeuCampo_AfterUpdate()
SeuCampo = TiraAcento(SeuCampo)
End Sub

Glicerio foi você que fez esse código como está no comentário ?

Veja aqui postado em 2010 entre outros lugares;

http://scriptbrasil.com.br/forum/index.php?s=055a715afcb1e33b1e61f4ac9a810cc8&showtopic=145929

e aqui em 2003

http://www.vbweb.com.br/dicas_visual.asp?Codigo=1674



Leia a Regra Nº11 deste fórum. Ou retire o seu nome do comentario.

Qualquer duvida outro comentario em relação a este tópico, envie PM para mim.

Mestre JPaulo ...
Já o informei por MP,
desculpe o mau entendido ...
já corrigi o post acima...

Tranquilo.

Boa noite JPaulo

Perfeito como sempre ... já faz a alteração correcta.

Será que dá para aplicar a mesma função num caixa de combinação para selecionar um nome ao digitar ?

Obrigado.

Poder pode Assis, mas o codigo terá de sofrer algumas alterações.

Pergunta:
Vale a pena ?

Se ao digitar a combox autocompletar-se não tem mais problema.

Boa noite JPaulo

Valer a pena vale porque quem vai utilizar esta situação são pessoas que normalmente complicam o fácil. É que neste caso eu não posso impedir a repetição do mesmo nome, isto porque neste meio existe muita gente com o mesmo nome.
A questão é que ao procurar um nome, se digitar um acento já tudo muda, pois pode dar a impressão de que o nome não estar registado, e voltam a regista-lo.
Portanto se pode ser agradecia.

Obrigado

Bom Dia Assis;

Entendi o que pretende e penso que pode utilizar o simples;

Faça o teste na sua Combobox ao digitar por exemplo, João, José, Tânia, etc....

Private Sub SuaCombox_KeyDown(KeyCode As Integer, Shift As Integer)
'Combinação do KeyCode para CarateresEspeciais "~´`^<>#$%&?¿,.:;@-\+-=()*/''"
    If KeyCode >= 186 And KeyCode <= 220 Then
        KeyCode = 0
    Else
        Exit Sub
    End If
End Sub

Bom dia JPaulo
É mesmo o simples.
Obrigado

Obrigado pelo retorno Assis, o forum agradece.

JPaulo

Qual a tecla a retirar do código para permitir a letra "ç".
Obrigado

Boa tarde JPaulo



Desculpe a insistencia mas qual a tecla para retirar do código para permitir a letra "ç".

Private Sub SuaCombox_KeyDown(KeyCode As Integer, Shift As Integer)
'Combinação do KeyCode para CarateresEspeciais "~´`^<>#$%&?¿,.:;@-\+-=()*/''"
If KeyCode >= 186 And KeyCode <= 220 Then
KeyCode = 0
Else
Exit Sub
End If
Obrigado

Ola Assis

É a tecla 192

Para saber o numero de uma tecla, coloque um formulario com visualizar teclas=sim e no KeyDown coloque;

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
MsgBox KeyCode
End Sub

Com o form aberto, pressione uma tecla e a msgbox mostra o numero.

Boa JPaulo
If KeyCode >= 186 And KeyCode <= 191 And KeyCode <= 193 And KeyCode <= 220 Then
KeyCode = 0
Else
Exit Sub
End If
Assim já consigo por a Letra "Ç"

Obrigado

Valew Assis.

Boa noite, pessoal

Da mesma forma que o Assis iniciou esse tópico, quero que o campo de texto do meu formulário tire os acentos dos caracteres inseridos, mas deixe os "Ç". Vi as funções no tópico e quis testá-las no meu formulário/tabela, mas sou iniciante e não sei onde colar estes códigos. Alguém pode me ajudar?

Desde já agradeço a atenção!

Boa tarde!
Mestre J Paulo como faço para usar essa função em uam consulta atualização de modo que eu possa atualizar um determinado campo numa tabela?
Pois tenho varios clinete ja casdatrados e queria atulizar tudo de uma vez

Obrigado..

Bom pessoal, a muito venho sugando daqui chegou a hora de contribuir compartilhando

neste tópico fiz uma junção de varias funções colhidas aqui que faz jus ao ditado "Matar dois coelhos, com uma cajadada!"
Esta junção de funções faz (no evento foco):

• Pinta o campo

• Negirta o campo

• Italica a fonte

• Remove acentos

• Caixa Alta no campo

Espero que aproveitem:
Modo de uso: Em form_load, adicione "Call fncMontaEventos(Me)"

Código:


Option Compare Database
Option Explicit

Public Function fncMontaEventos(frm As Form)
Dim ctl As control
'-------------------------------------------------------------------------------------------------------
'Esta função deve ser chamada no evento "ao carregar" do formulário.  Exemplo: call fncMontaEventos(me)
'-------------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------
'Percorre todos os controles do Formulário informado no argumento frm da função
'------------------------------------------------------------------------------
  For Each ctl In frm.Controls
    Select Case ctl.ControlType
      '-----------------------------------------------------------------------------
      'Escrever as funções somente nos eventos dos controles tipo caixa de texto
      '-----------------------------------------------------------------------------
      Case acTextBox 'caixa de texto
        '----------------------------------------------------------------------------------------------------
        'Monta e escreve função fncPintacampo nos evento "ao receber foco" da caixa de teexto
        'Lembrando que estamos dentro do faço FOR. Significa que todas as caixas de texto receberão a função
        '----------------------------------------------------------------------------------------------------
        If ctl.OnGotFocus = vbNullString Then ctl.OnGotFocus = "=fncPintaCampo([" & ctl.name & "],1)"  'Cor Amarela
        '--------------------------------------------------------------------------------------
        'Monta e escreve a função fncPintacampo() no evento "ao Perder Foco" da caixa de Texto
        '--------------------------------------------------------------------------------------
        If ctl.OnLostFocus = vbNullString Then ctl.OnLostFocus = "=fncPintaCampo([" & ctl.name & "],0)" 'Cor Branca
      Case acComboBox  'combobox
        If ctl.OnGotFocus = vbNullString Then ctl.OnGotFocus = "=fncPintaCampo([" & ctl.name & "],1)"  'Cor Amarela
        If ctl.OnLostFocus = vbNullString Then ctl.OnLostFocus = "=fncPintaCampo([" & ctl.name & "],0)" 'Cor Branca
      Case acCommandButton 'botões
        If ctl.OnGotFocus = vbNullString Then ctl.OnGotFocus = "=fncPintaBotao([" & ctl.name & "], 1)" 'cor vermelha
        If ctl.OnLostFocus = vbNullString Then ctl.OnLostFocus = "=fncPintaBotao([" & ctl.name & "], 0)" 'cor preta
      Case acListBox 'listbox
        If ctl.OnGotFocus = vbNullString Then ctl.OnGotFocus = "=fncPintaCampo([" & ctl.name & "],1)"  'Cor Amarela
        If ctl.OnLostFocus = vbNullString Then ctl.OnLostFocus = "=fncPintaCampo([" & ctl.name & "],0)" 'Cor Branca
    End Select
  Next
End Function

Public Function fncPintaCampo(ctl As control, cor As Byte)
On Error Resume Next
  '--------------------------------------------
  'Altera a cor do campo que possui o foco
  'Ao recebr o foco, passa para a cor Amarela
  'Ao perder o foco, passa para a cor branco
  '--------------------------------------------
  ctl.BackColor = Switch(cor = 0, RGB(255, 255, 255), cor = 1, RGB(255, 253, 185), cor = 3, RGB(224, 238, 224))
  ctl.FontBold = IIf(cor = 0, False, True)
  ctl.FontItalic = IIf(cor = 0, False, True)
  ctl.value = UCase(ctl.value)
  ctl.value = DLTiraAcentos(ctl.value)
  '------------------------------------------------------
  'Ao receber o foco posiciona o cursor no final do texto
  '------------------------------------------------------
  If ctl.ControlType = acTextBox Or ctl.ControlType = acComboBox And cor = 1 Then ctl.SelStart = Len(ctl.value & "")
End Function

Public Function fncPintaBotao(ctl As control, cor As Integer)
  ctl.BackColor = Switch(cor = 0, RGB(255, 255, 255), cor = 1, RGB(255, 253, 185), cor = 3, RGB(224, 238, 224)) 'IIf(cor = 0, False, True)
  ctl.FontBold = IIf(cor = 0, False, True)
End Function

Public Function DLTiraAcentos(ByVal strOriginal As String)
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 = strToReturn
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