Autor Tema: Sin tildes  (Leído 43 veces)

Desconectado xavi

  • Administrador
  • Habitual
  • *****
  • Mensajes: 176
Sin tildes
« en: Abril 23, 2020, 12:58:52 am »
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.


Código: [Seleccionar]
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