SEM ACENTO

Citação:

'==================================================
'Substituir palavras com acentos por sem acentos
'Ex.: ã --> a
'==================================================
Public Const UM = 1


Public Function TiraAcentos(Texto As String)
On Error GoTo Trata_erro
'necessito lcase (texto)
Dim I As Integer, J As Integer 'contadores pra percorer a matriz
Dim V(21, 1) As String * 1 'matriz de acentos e suas respectivas equivalentes
Dim A(38) As String 'vetor de caracteres invalidos
Dim TEMP As String, TMP As String 'vars temp que guardam os valores
Dim K As Integer 'contador pra percorrer a tmp
Dim TAM As Integer 'tamanho do texto
Dim TMPFINAL As String 'texto montagem, volta do procedimento
Dim CONT As Integer 'contador do vetor A


TEMP = LCase(Texto)
TAM = Len(TEMP)
TMPFINAL = vbNullString

V(0, 0) = "ã"
V(0, 1) = "a"
V(1, 0) = "á"
V(1, 1) = "a"
V(2, 0) = "à "
V(2, 1) = "a"
V(3, 0) = "à¢"
V(3, 1) = "a"
V(4, 0) = "à¤"
V(4, 1) = "a"

V(5, 0) = "é"
V(5, 1) = "e"
V(6, 0) = "à¨"
V(6, 1) = "e"
V(7, 0) = "ê"
V(7, 1) = "e"
V(8, 0) = "à«"
V(8, 1) = "e"

V(9, 0) = "í"
V(9, 1) = "i"
V(10, 0) = "à¬"
V(10, 1) = "i"
V(11, 0) = "à¯"
V(11, 1) = "i"
V(12, 0) = "à®"
V(12, 1) = "i"

V(13, 0) = "ú"
V(13, 1) = "u"
V(14, 0) = "à¹"
V(14, 1) = "u"
V(15, 0) = "à¼"
V(15, 1) = "u"
V(16, 0) = "à»"
V(16, 1) = "u"

V(17, 0) = "õ"
V(17, 1) = "o"
V(18, 0) = "ó"
V(18, 1) = "o"
V(19, 0) = "à²"
V(19, 1) = "o"
V(20, 0) = "à'"
V(20, 1) = "o"
V(21, 0) = "à¶"
V(21, 1) = "o"


A(0) = "'"
A(1) = "!"
A(2) = "@"
A(3) = "#"
A(4) = "$"
A(5) = "%"
A(6) = "&"
A(7) = "*"
A(8) = "("
A(9) = ")"
A(10) = "-"
A(11) = "_"
A(12) = "="
A(13) = "+"
A(14) = "§"
A(15) = "|"
A(16) = "\"
A(17) = ","
A(18) = "<"
A(19) = "."
A(20) = ">"
A(21) = ";"
A(22) = ":"
A(23) = "?"
A(24) = "/"
A(25) = "º"
A(26) = "-"
A(27) = "]"
A(28) = "}"
A(29) = "["
A(30) = "{"
A(31) = "¬"
A(32) = "¢"
A(33) = "£"
A(34) = "ÂÂÂ'"
A(35) = "'"
A(36) = "~"
A(37) = "^"
A(38) = "¨"

For I = 0 To (TAM - UM)
TMP = Mid(Left(TEMP, I + UM), I + UM, TAM)
For J = 0 To 21
For K = 0 To UM
If TMP = V(J, K) Then
TMP = V(J, UM)
End If
If TMP = "ç" Then '============================================
TMP = "c" ' Implementação de Stop Words caso ç --> c =
End If '============================================
For CONT = 0 To 38
If TMP = A(CONT) Then
TMP = " "
End If
Next
Next
Next
TMPFINAL = TMPFINAL & TMP
Next

TiraAcentos = TMPFINAL
Exit Function
Trata_erro:
MsgBox "Erro nº " & Err.Number & vbCrLf & "Erro:" & Err.Description
Err.Clear
Resume Next
End Function

Public Function LimparTexto(Texto As String) As String
Dim CodAsc As Integer, PosicaoTxt As Long
Texto = Trim(Texto)
For PosicaoTxt = 1 To Len(Texto)
CodAsc = Asc(Mid(Texto, PosicaoTxt, 1))
  Select Case CodAsc
     Case 192 To 197
        CodAsc = Asc("A")
     Case 224 To 229
        CodAsc = Asc("a")
     Case 200 To 203
        CodAsc = Asc("E")
     Case 232 To 235
        CodAsc = Asc("e")
     Case 204 To 207
        CodAsc = Asc("I")
     Case 236 To 239
        CodAsc = Asc("i")
     Case 199
        CodAsc = Asc("C")
     Case 231
        CodAsc = Asc("c")
     Case 242 To 246
        CodAsc = Asc("o")
     Case 249 To 252
        CodAsc = Asc("u")
     Case 210 To 214
        CodAsc = Asc("O")
     Case 217 To 220
        CodAsc = Asc("U")
  End Select
    LimparTexto = LimparTexto & Chr(CodAsc)
    LimparTexto = Replace(LimparTexto, "  ", " ")
Next
End Function