VBA Tips - Retirando acento - Remove and replace accent characters from a string.

Sei que você já tem uma função que retira acento, aliás, eu mesmo já postei uma solução destas por aqui. Mas sempre é bom olharmos para mais de uma solução:

Function ConvertAccent(ByVal inputString As String) As String

' http://www.vbforums.com/archive/index.php/t-483965.html

 

Const AccChars As String = _

      "²—­–ŠŽšžŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïðñòóôõöùúûüýÿ'"

Const RegChars As String = _

      "2---SZszYAAAAAACEEEEIIIIDNOOOOOUUUUYaaaaaaceeeeiiiidnooooouuuuyy'"

 

Dim i As Long, j As Long

Dim tempString As String

Dim currentCharacter As String

Dim found As Boolean

Dim foundPosition As Long

 

  tempString = inputString

 

  ' loop through the shorter string

 Select Case True

    Case Len(AccChars) <= Len(inputString)

      ' accent character list is shorter (or same)

     ' loop through accent character string

     For i = 1 To Len(AccChars)

 

        ' get next accent character

       currentCharacter = Mid$(AccChars, i, 1)

 

        ' replace with corresponding character in "regular" array

       If InStr(tempString, currentCharacter) > 0 Then

          tempString = Replace(tempString, currentCharacter, _

                               Mid$(RegChars, i, 1))

        End If

      Next i

    Case Len(AccChars) > Len(inputString)

      ' input string is shorter

     ' loop through input string

     For i = 1 To Len(inputString)

 

        ' grab current character from input string and

       ' determine if it is a special char

       currentCharacter = Mid$(inputString, i, 1)

        found = (InStr(AccChars, currentCharacter) > 0)

 

        If found Then

 

          ' find position of special character in special array

         foundPosition = InStr(AccChars, currentCharacter)

 

          ' replace with corresponding character in "regular" array

         tempString = Replace(tempString, currentCharacter, _

                               Mid$(RegChars, foundPosition, 1))

 

        End If

      Next i

  End Select

 

  ConvertAccent = tempString

End Function

Referências: 

Tags: VBA, Outlook, email, anexar,