Biblioteca de Clases,Funciones y Sub-rutinas.

[PosProdukcion]

Saludos, aquí una serie de funciones para:

- quitar las tildes y signos de puntuación
- crear URL amigables a partir de una frase

Código ASP:

'=======================================================
    'getUrlAmigable
    'Elimina las tildes y las palabras irrelevantes y cambia los espacios por -
    '=======================================================
    Function getUrlAmigable(ByVal strTitulo)
        if strTitulo<>"" then
            strTitulo = quitaPuntuaciones(strTitulo, " ")
            'Al sustituir los signos de puntuacion por espacios pueden haber quedado
            'varios espacios seguidos, se cambian por uno solo
            strTitulo = Replace(strTitulo, "  ", " ")
            strTitulo = lcase(quitaTildes(strTitulo))
 
            'Esta es la lista de palabras consideradas irrelevantes para formar la URL
            Dim irrelevantes(20), iWd
 
            irrelevantes(0) = "el"
            irrelevantes(1) = "la"
            irrelevantes(2) = "las"
            irrelevantes(3) = "lo"
            irrelevantes(4) = "los"
            irrelevantes(5) = "a"
            irrelevantes(6) = "con"
            irrelevantes(7) = "de"
            irrelevantes(8) = "desde"
            irrelevantes(9) = "en"
            irrelevantes(10) = "para"
            irrelevantes(11) = "por"
            irrelevantes(12) = "sin"
            irrelevantes(13) = "es"
            irrelevantes(14) = "son"
            irrelevantes(15) = "este"
            irrelevantes(16) = "esto"
            irrelevantes(17) = "esta"
            irrelevantes(18) = "estos"
            irrelevantes(19) = "estas"
            irrelevantes(20) = "y"
 
            'Añade un espacio al principio y al final para sustituir solo palabras
            'completas incluyendo la primera y ultima palabras
            strTitulo = " " & strTitulo & " "
            for iWd=0 to uBound(irrelevantes)
                strTitulo = Replace(strTitulo, " " & irrelevantes(iWd) & " ", " ")
            next
            strTitulo = Trim(strTitulo)
            strTitulo = Replace(strTitulo, " ", "-")
        end if
        getUrlAmigable = strTitulo
    End function
 

Utiliza las siguientes funciones:

Código ASP:

'====================================================
    'quitaTildes()
    'Cambia los caracteres con tildes, ñ, ç por letras sin tilde o N o C
    'Elimina las tildes por completo, puede ser necesario al pasar datos
    'desde UTF-8 a sistemas con ISO-8859-1
     Function quitaTildes(texto)
        If not EsNulo(texto) Then
            texto = Replace(texto, "¡", "")
            texto = Replace(texto, "¿", "")
            texto = Replace(texto, "'", "")
            texto = Replace(texto, "º", "o", 1, Len(texto), 1)
            texto = Replace(texto, "ª", "a", 1, Len(texto), 1)
 
            Texto = Replace(Texto, "á", "a", 1, Len(Texto), 1)
            Texto = Replace(Texto, "é", "e", 1, Len(Texto), 1)
            Texto = Replace(Texto, "í", "i", 1, Len(Texto), 1)
            Texto = Replace(Texto, "ó", "o", 1, -1, 1)
            Texto = Replace(Texto, "ú", "u", 1, Len(Texto), 1)
            Texto = Replace(Texto, "ñ", "n", 1, Len(Texto), 1)
            texto = Replace(texto, "ç", "c", 1, Len(texto), 1)
'
            texto = Replace(texto, "Á", "A", 1, Len(texto), 1)
            texto = Replace(texto, "É", "E", 1, Len(texto), 1)
            texto = Replace(texto, "Í", "I", 1, Len(texto), 1)
            texto = Replace(texto, "Ó", "O", 1, Len(texto), 1)
            texto = Replace(texto, "Ú", "U", 1, Len(texto), 1)
            texto = Replace(texto, "Ñ", "N", 1, Len(texto), 1)
            texto = Replace(texto, "Ç", "C", 1, Len(texto), 1)
 
            texto = Replace(texto, "à", "a", 1, Len(Texto), 1)
            texto = Replace(texto, "è", "e", 1, Len(Texto), 1)
            texto = Replace(texto, "ì", "i", 1, Len(Texto), 1)
            texto = Replace(texto, "ò", "o", 1, Len(Texto), 1)
            texto = Replace(texto, "ù", "u", 1, Len(Texto), 1)
                                        
            texto = Replace(texto, "À",  "A", 1, Len(texto), 1) 
            texto = Replace(texto, "È",  "E", 1, Len(texto), 1) 
            texto = Replace(texto, "Ì",  "I", 1, Len(texto), 1) 
            texto = Replace(texto, "Ò",  "O", 1, Len(texto), 1) 
            texto = Replace(texto, "Ù",  "U", 1, Len(texto), 1) 
 
            texto = Replace(texto, "ä", "a", 1, Len(Texto), 1)
            texto = Replace(texto, "ë", "e", 1, Len(Texto), 1)
            texto = Replace(texto, "ï", "i", 1, Len(Texto), 1)
            texto = Replace(texto, "ö", "o", 1, Len(Texto), 1)
            texto = Replace(texto, "ü", "u", 1, Len(Texto), 1)
 
            texto = Replace(texto, "Ä",  "A", 1, Len(texto), 1) 
            texto = Replace(texto, "Ë",  "E", 1, Len(texto), 1) 
            texto = Replace(texto, "Ï",  "I", 1, Len(texto), 1) 
            texto = Replace(texto, "Ö",  "O", 1, Len(texto), 1) 
            texto = Replace(texto, "Ü",  "U", 1, Len(texto), 1) 
 
            texto = Replace(texto, "â", "a", 1, Len(Texto), 1)
            texto = Replace(texto, "ê", "e", 1, Len(Texto), 1)
            texto = Replace(texto, "î", "i", 1, Len(Texto), 1)
            texto = Replace(texto, "ô", "o", 1, Len(Texto), 1)
            texto = Replace(texto, "û", "u", 1, Len(Texto), 1)
 
            texto = Replace(texto, "Â",  "A", 1, Len(texto), 1) 
            texto = Replace(texto, "Ê",  "E", 1, Len(texto), 1) 
            texto = Replace(texto, "Î",  "I", 1, Len(texto), 1) 
            texto = Replace(texto, "Ô",  "O", 1, Len(texto), 1) 
            texto = Replace(texto, "Û",  "U", 1, Len(texto), 1) 
       Else
            texto = ""
        End If
        quitaTildes = texto
    End Function
 

Y quitaPuntuaciones(), esta última se debería mejorar con el uso de expresiones regulares, lo dejo para otro día

Código ASP:

'====================================================
    'quitaPuntuaciones()
    'Sustituye los signos de puntuacion por la cadena dada en "cambiar_por"
     Function quitaPuntuaciones(texto, cambiar_por)
        if texto<>"" then
            texto = Replace(texto, "\", cambiar_por)
            texto = Replace(texto, "!", cambiar_por)
            texto = Replace(texto, """", cambiar_por)
            texto = Replace(texto, "·", cambiar_por)
            texto = Replace(texto, "#", cambiar_por)
            texto = Replace(texto, "|", cambiar_por)
            texto = Replace(texto, "$", cambiar_por)
            texto = Replace(texto, "~", cambiar_por)
            texto = Replace(texto, "%", cambiar_por)
            texto = Replace(texto, "&", cambiar_por)
            texto = Replace(texto, "/", cambiar_por)
            texto = Replace(texto, "(", cambiar_por)
            texto = Replace(texto, ")", cambiar_por)
            texto = Replace(texto, "=", cambiar_por)
            texto = Replace(texto, "'", cambiar_por)
            texto = Replace(texto, "¡", cambiar_por)
            texto = Replace(texto, "?", cambiar_por)
            texto = Replace(texto, "¿", cambiar_por)
            texto = Replace(texto, "^", cambiar_por)
            texto = Replace(texto, "`", cambiar_por)
            texto = Replace(texto, "´", cambiar_por)
            texto = Replace(texto, "[", cambiar_por)
            texto = Replace(texto, "]", cambiar_por)
            texto = Replace(texto, "{", cambiar_por)
            texto = Replace(texto, "}", cambiar_por)
            texto = Replace(texto, "+", cambiar_por)
            texto = Replace(texto, "*", cambiar_por)
            texto = Replace(texto, "¨", cambiar_por)
            texto = Replace(texto, ";", cambiar_por)
            texto = Replace(texto, ",", cambiar_por)
            texto = Replace(texto, ".", cambiar_por)
            texto = Replace(texto, ":", cambiar_por)
            texto = Replace(texto, "-", cambiar_por)
            texto = Replace(texto, "_", cambiar_por)
            texto = Replace(texto, ">", cambiar_por)
            texto = Replace(texto, "<", cambiar_por)
            texto = Replace(texto, "€", cambiar_por)
        end if
        quitaPuntuaciones = texto
    End function