Palabras clave: tildes, acentos, limpiar
Autor: Xavi
Extraído de: Experiencia propia
Intentando generalizar una función que me permita convertir cualquier texto con acentos a otro sin acentos y añadiendo la capacidad de poder incluir niveles de restricción de caracteres especiales, ha salido esta función.
Debe copiarse en un módulo independiente.
A la hora de utilizarse se debe pasar la cadena a convertir.
Opcionalmente se indica el nivel de restricción de los especiales. Por defecto es Libre lo que devolverá todos los caracteres especiales y únicamente sustituirá los caracteres acentuados.
Si se utiliza el nivel de restricción 1 (restringido), debe indicarse la cadena de caracteres prohibidos. Si no se indica el sistema propone una colección.
Si se utiliza el nivel de restricción 3 (Estricto) la cadena de respuesta solo permitirá letras mayúsculas, letras minúsculas, números y espacios.
La función puede ampliar los caracteres acentuados. Solo es necesario añadir los caracteres adecuados a las cadenas strConAcentos y strSinAcentos.
Public Enum eUtl_TildesRestriccion
Libre = 0
Restringido = 1
Estricto = 2
End Enum
Function SinTildesEvo(strText As String, Optional intSinEspeciales As eUtl_TildesRestriccion = 0, Optional strEspeciales As String = ".,:;()-&%!?¡¿ºª*çÇ@_·)$") As String
On Error GoTo ErrorHandler
Dim strConAcentos As String
Dim strSinAcentos As String
Dim c As Integer
Dim strChar As String
Dim intPos As Integer
Dim strLimpia1 As String
Dim strLimpia2 As String
strConAcentos = "áàäâéèëêíìïîóòöôúùüûÁÀÄÂÉÈËÊÍÌÏÎÓÒÖÔÚÙÜÛ"
strSinAcentos = "aaaaeeeeiiiioooouuuuAAAAEEEEIIIIOOOOUUUU"
' Recorremos el texto pasado como argumento
For c = 1 To Len(strText)
' Obtenemos el carácter a evaluar
strChar = Mid(strText, c, 1)
' Miramos si existe en la cadena de caracteres acentuados
intPos = InStr(1, strConAcentos, strChar, vbBinaryCompare)
If intPos > 0 Then
' Al existir sustituimos
strLimpia1 = strLimpia1 & Mid(strSinAcentos, intPos, 1)
Else
' Al no existir lo aceptamos
strLimpia1 = strLimpia1 & strChar
End If
Next
' Evaluamos si se quitan los especiales
Select Case intSinEspeciales
Case eUtl_TildesRestriccion.Libre ' Sin restricción: no se obvia ningún caracter especial
' Igualamos cadenas
strLimpia2 = strLimpia1
Case eUtl_TildesRestriccion.Restringido ' Restrictivo:solo los de la lista
' Recorremos la cadena
For c = 1 To Len(strLimpia1)
' Obtenemos el caracter a evaluar
strChar = Mid(strLimpia1, c, 1)
' Miramos si existe en la cadena de caracteres especiales
intPos = InStr(1, strEspeciales, strChar, vbBinaryCompare)
If intPos = 0 Then
' Al no existir podemos añadir el caracter
strLimpia2 = strLimpia2 & strChar
End If
Next
Case eUtl_TildesRestriccion.Estricto ' Ultrarestrictivo: ningun caractrer que no sea letra, numero o espacio
For c = 1 To Len(strLimpia1)
strChar = Mid(strLimpia1, c, 1)
Select Case Asc(strChar)
Case 48 To 57, 65 To 90, 97 To 122, 32
strLimpia2 = strLimpia2 & strChar
End Select
Next
End Select
SinTildesEvo = strLimpia2
ExitProcedure:
On Error GoTo 0
Exit Function
ErrorHandler:
Select Case Err.Number
Case 0
Case Else
MsgBox "Error " & Err.Number & " - " & Err.Description
Resume ExitProcedure
End Select
End Function
