REMOVENDO ACENTOS DE PALAVRAS

Aqui temos 7 exemplos diferentes com a mesma finalidade.
As 7 são de 4 autores: Ribamar FS, Carlos Manuel e José Luiz e Rogério
Deixei as versões anteriores para mostrar a evolução do código.

Function SemAcentos(sString As String)
    Dim x As Integer
    Dim l(30) As String 'Supondo que a maior palavra tem 30 caracteres
    
    If Len(sString) > 30 Then
        MsgBox "A palavra excede o tamanho suportado!"
        Exit Function
    End If
    
    For x = 0 To Len(sString) - 1
        l(x) = Mid(sString, x + 1, 1)
        If Asc(l(x)) >= 192 Then    'Acentuados tem código >=192
            Select Case l(x)
                Case "ã"
                    l(x) = "a"
                Case "á"
                    l(x) = "a"
                Case "é"
                    l(x) = "e"
                Case "ê"
                    l(x) = "e"
                Case "í"
                    l(x) = "i"
                Case "ó"
                    l(x) = "o"
                Case "ô"
                    l(x) = "o"
                Case "õ"
                    l(x) = "o"
                Case "ü"
                    l(x) = "u"
                Case "ú"
                    l(x) = "u"
                Case "ç"
                    l(x) = "c"
                Case Else
            End Select
        End If
    Next x
    SemAcentos = l(0) + l(1) + l(2) + l(3) + l(4) + l(5) + l(6) + l(7) + l(8) + l(9) + _
        l(10) + l(11) + l(12) + l(13) + l(14) + l(15) + l(16) + l(17) + l(18) + l(19) + l(20) + _
        l(21) + l(22) + l(23) + l(24) + l(25) + l(26) + l(27) + l(28) + l(29)
End Function

Private Sub cmdSemAcentos_Click()
    txtSemAcentos = SemAcentos(txtSemAcentos)
End Sub


REMOVENDO ACENTOS DE PALAVRAS -VERSÃ0 2

Function SemAcentos(sString As String)
    Dim x As Integer
    Dim sStringFinal As String
    
    Dim letra() As String
    
    For x = 0 To Len(sString) - 1
    ReDim Preserve letra(x)
        letra(x) = Mid(sString, x + 1, 1)
        
        If Asc(letra(x)) >= 192 Then    'Acentuados tem código >=192
            Select Case letra(x)
                Case "ã", "á"
                    letra(x) = "a"
                Case "é", "ê"
                    letra(x) = "e"
                Case "í"
                    letra(x) = "i"
                Case "ó", "ô", "õ"
                    letra(x) = "o"
                Case "ü", "ú"
                    letra(x) = "u"
                Case "ç"
                    letra(x) = "c"
                Case Else
            End Select
        End If
    Next x
    
    For x = 0 To Len(sString) - 1
        sStringFinal = sStringFinal + letra(x)
    Next x
    
    SemAcentos = sStringFinal
End Function

Private Sub cmdSemAcentos_Click()
    txtSemAcentos = SemAcentos(txtSemAcentos)
End Sub


REMOVENDO ACENTOS DE PALAVRAS -VERSÃ0 3

Esta versão foi desenvolvida pelo colega Carlos Manoel (disgrace@visto.com)
da lista access-pt.

Private Function Subs(letra As String) As String
    Select Case letra
        Case "ã"
            Subs = "a"
        Case "á"
            Subs = "a"
        Case "é"
            Subs = "e"
        Case "ê"
            Subs = "e"
        Case "í"
            Subs = "i"
        Case "ó"
            Subs = "o"
        Case "ô"
            Subs = "o"
        Case "õ"
            Subs = "o"
        Case "ü"
            Subs = "u"
        Case "ú"
            Subs = "u"
        Case "ç"
            Subs = "c"
        Case Else
            Subs = letra
        End Select

End Function

Function SemAcentos(texto As String) As String
    Dim x As Integer, caracter As String
    
    'texto=Trim(texto)
    SemAcentos = texto
    For x = 1 To Len(texto)
        caracter = Mid(texto, x, 1)
        If Asc(caracter) >= 192 Then
            SemAcentos = Left(SemAcentos, x - 1) & Subs(caracter) & Right(SemAcentos, Len(texto) - x)
        End If
    Next x
    
End Function


REMOVENDO ACENTOS DE PALAVRAS -VERSÃ0 4

Function SemAcentos(sString As String) As String
'Função original criada por Ribamar F. S. (ribafs@yahoo.com)
'adaptada em 20/04/01 por José Luiz de Souza Gomes (jlsgomes@uem.br)
    
    
    Dim x As Integer
    Dim strnew As String
    
    'Para Strings de qualquer tamanho
    ReDim l(Len(sString)) As String
    
    'inicializa a variável strnew com uma seqüência nula
    strnew = ""
    
    'Percorre o campo caractere a caractere, até o final
    For x = 0 To Len(Trim(sString)) - 1
        l(x) = Mid(sString, x + 1, 1)
        If Asc(l(x)) >= 192 Then   'Os caracteres acentuados são maiores
que
192
            'concatena (junta) cada letra com a anterior para formar a
nova
string
            strnew = strnew & TrocaLetra(l(x))
        Else
            strnew = strnew & l(x)
        End If
    Next x
    
    'Retorna a nova string
    SemAcentos = strnew
    
    'para uso com DBF ou Clipper, pode-se converter para maiúsculas,
assim:
    'SemAcentos = UCase(strnew)
    
End Function
            
Function TrocaLetra(s As String) As String
'função complementar à rotina que toma uma String que contém acentos e
'transforma cada letra acentuada em sua equivalente sem acento
'Criada por Ribamar F. S (ribafs@yahoo.com)
'Adaptada por: José Luiz de Souza Gomes (jlsgomes@uem.br)
   
   Dim LetraSemAcento As String
   
   Select Case s
          Case "ã"
             LetraSemAcento = "a"
          Case "á"
             LetraSemAcento = "a"
          Case "é"
             LetraSemAcento = "e"
          Case "ê"
             LetraSemAcento = "e"
          Case "í"
             LetraSemAcento = "i"
          Case "ó"
             LetraSemAcento = "o"
          Case "ô"
             LetraSemAcento = "o"
          Case "õ"
             LetraSemAcento = "o"
          Case "ü"
             LetraSemAcento = "u"
          Case "ú"
             LetraSemAcento = "u"
          Case "ç"
             LetraSemAcento = "c"
          Case Else
      End Select
      TrocaLetra = LetraSemAcento
End Function


REMOVENDO ACENTOS DE PALAVRAS -VERSÃ0 5

Esta versão foi desenvolvida pelo colega Carlos Manoel (disgrace@visto.com)
da lista access-pt.

Private Function Subs(Cod As Integer) As String

    Select Case Cod
        Case 224 To 228
            Subs = "a"
        Case 232 To 235
            Subs = "e"
        Case 236 To 239
            Subs = "i"
        Case 242 To 246
            Subs = "o"
        Case 249 To 252
            Subs = "u"
        Case 231
            Subs = "c"
        Case 241
            Subs = "n"
        Case Else
            Subs = Chr$(Cod)
        End Select

End Function

Function SemAcentos(texto As String) As String
    Dim x As Integer, caracter As Integer
    
    texto = Trim(texto)
    SemAcentos = texto
    For x = 1 To Len(texto)
        caracter = Asc(Mid(texto, x, 1))
        If caracter >= 192 Then
            SemAcentos = Left(SemAcentos, x - 1) & Subs(caracter) & Right(SemAcentos, Len(texto) - x)
        End If
    Next x
    
End Function


REMOVENDO ACENTOS DE PALAVRAS -VERSÃ0 6

Function SemAcentos(sString As String) As String
'Função original criada por Ribamar F. S. (ribafs@yahoo.com)
'adaptada em 20/04/01 por José Luiz de Souza Gomes (jlsgomes@uem.br)
    
    
    Dim x As Integer
    Dim strnew As String
    
    'Para Strings de qualquer tamanho
    ReDim l(Len(sString)) As String
    
    'inicializa a variável strnew com uma seqüência nula
    strnew = ""
    
    'Percorre a string, caractere a caractere, até o final
    For x = 0 To Len(Trim(sString)) - 1
        l(x) = Mid(sString, x + 1, 1)
        If Asc(l(x)) >= 192 Then   'Os caracteres acentuados são maiores
que
192
            'concatena (junta) cada letra com a anterior para formar a
nova
string
            strnew = strnew & TrocaLetra(l(x))
        Else
            strnew = strnew & l(x)
        End If
    Next x
    
    'Retorna a nova string
    SemAcentos = strnew
    
    'para uso com Dbase ou Clipper, pode-se converter para maiúsculas,
assim:
    'SemAcentos = UCase(strnew)
    
End Function
            
Function TrocaLetra(s As String) As String
'função complementar à rotina que recebe uma String que contém acentos e
'transforma cada letra acentuada em sua equivalente sem acento
'Criada por Ribamar F. S (ribafs@yahoo.com)
'Adaptada por: José Luiz de Souza Gomes (jlsgomes@uem.br)
   
'Algumas formas de acentuação não são usadas na Língua Portuguesa,
'como û ou ë, por exemplo, mas foram incluídas para tentar ser mais
'abrangente.
   
'Bug conhecido: Letras maíusculas acentuadas serão convertidas para
minúsculas
   
   Dim LetraSemAcento As String
   
   Select Case s
          Case "ã", "á", "à", "â", "ä"
               LetraSemAcento = "a"
          Case "é", "ê", "è", "ë"
               LetraSemAcento = "e"
          Case "í", "ì", "î", "ï"
               LetraSemAcento = "i"
          Case "ó", "ò", "ô", "õ", "ö"
               LetraSemAcento = "o"
          Case "ü", "ú", "ù", "û"
               LetraSemAcento = "u"
          Case "ç"
               LetraSemAcento = "c"
          Case Else
   End Select
   TrocaLetra = LetraSemAcento
End Function


REMOVENDO ACENTOS DE PALAVRAS -VERSÃ0 7

Function LimpaAcentos(S As String) As String
'* Objetivo - Retirar os acentos, sem modificar as strings.
'* Parametros -  S - String a ter acentos retirados
'* Adaptada do Algoritmo para Retirar Acentos para Delphi de Marcio 
Castilho
'* Publicada em 08/12/00 para o site da Revista Delphi Journal
'* Adaptacao: Rogerio Olimpio Lourenco de Oliveira - 2000
'* (5120.rogerio@bradesco.com.br)

Dim Acentos1 As String, Acentos2 As String, TMP As String, tmp2 As String
Dim i As Integer, Aux As Integer
    Acentos1 = "ÀÌÒÙÈÁÍÓÚÉÃÏÕÜËÄÖÂÎÔÛÊàìòùèáíóúéãïõüëáöâîôûêÇç"
    Acentos2 = "AIOUEAIOUEAIOUEAOAIOUEaioueaioueaioueaoaioueCc"
    tmp2 = ""
     For i = 1 To Len(S)
        Aux = InStr(1, Acentos1, Mid(S, i, 1), 0)
        If (Aux <= 0) Then
           TMP = Mid(S, i, 1)
        Else
            TMP = Mid(Acentos2, Aux, 1)
        End If
        tmp2 = tmp2 + TMP
    Next i
    LimpaAcentos = tmp2
End Function

******************************
Cantinho dos Amantes do Access
www.ribafs.hpg.com.br