<%
'////////////////////////////
'//// NOMBRE:
'//// VERSIÓN: 1.0
'//// AUTOR: Jairo Blanco
'//// WEB: http://www.jairoblanco.com
'//// FECHA: 02/12/2004
'//// DESCRIPCIÓN:
'////
'//// Clase que devuelve automáticamente las keywords de un texto dado. Para ello
'//// la clase utiliza varios archivos que contienen un diccionario con advervios, preposiciones
'//// y palabras frecuentes que serán las suprimidas a la hora de devolver las keywords.
'//// Si se quire añadir nuestra lista de palabras propias que queremos que no aparezcan en las keywords, sólo tenemos
'//// que añadir un fichero con las palabras una por fila dentro del directorio que indiquemos en la propiedad "FilesVirtualDir".
'////
'//// PROPIEDADES:
'////
'//// FilesVirtualDir: Directorio virtual en el que se encuentran los ficheros de diccionario. Por defecto es "/dictionary/"
'//// Files: Nombre de los ficheros de diccionario separados por ",". Por defecto "usuales.dic,adverbios.a,adverbios.bc,adverbios.de,adverbios.fgh
'//// ,adverbios.ij,adverbios.lm,adverbios.no,adverbios.pq,adverbios.rs,adverbios.t-z
'////
'//// MÉTODOS:
'////
'//// getAutokeyWords(byVal sText, byVal iCharLImit , byVal iKeyWLimit)
'//// Descripción: Función que devuelve automáticamente las keywords de un texto dado
'//// IN:
'//// sTex: Texto del cuál extraer las keywords
'//// iKeyWLimit: Límite de palabras a extraer. Si pasamos 0 devuelve todos las palabras.
'//// OUT: keywords separadas por ", "
'///////////////////////////
Class AutoKeyWords
dim sPathFiles
dim sArchivos
Public Property Let FilesVirtualDir ( valor )
sPathFiles = valor
End Property
Public Property Get FilesVirtualDir
FilesVirtualDir = sPathFiles
End Property
Public Property Let Files ( valor )
sArchivos = valor
End Property
Public Property Get Files
Files = sArchivos
End Property
'////////////////////////////
'//// Autor: Jairo Blanco
'//// Fecha: 02/12/2004
'//// Descripción: Constructor de la clase. Se inicializan las propiedades
'///////////////////////////
Public Sub AutoKeyWords
'Directorio que contiene las palabras a filtrar
'Cambiar este directorio por el tuyo si quieres
sPathFiles="/datos/dictionary/"
'Ficheros que contiene las palabras que se descartarán.
sArchivos="usuales.dic,adverbios.a,adverbios.bc,adverbios.de,adverbios.fgh," & _
"adverbios.ij,adverbios.lm,adverbios.no,adverbios.pq,adverbios.rs,adverbios.t-z"
end sub
'////////////////////////////
'//// Autor: Jairo Blanco
'//// Fecha: 02/12/2004
'//// Descripción: Función que devuelve automáticamente las keywords de un texto dado
'//// IN:
'//// sTexT: Texto del cuál extraer las keywords
'//// iKeyWLimit: Límite de palabras a extraer. Si pasamos 0 devuelve todas las palabras.
'//// OUT: keywords separadas por ","
'///////////////////////////
Public function getAutokeyWords(byVal sText, byVal iKeyWLimit)
'Declaración de variables.
dim sTblDictionary
dim i,j,h
dim sTextofinal
dim tblArchivos,tblKeywords
dim sKeyword
tblArchivos=split(sArchivos,",")
'Elimino etiquetas Html
sText=StripHTML(sText)
'eliminamos acentos
sText = EliminarAcentos(sText)
'ponemos el texto en minusculas
sText = lcase(sText)
tblKeywords=split(sText," ")
'Recorro todos los archivos de adverbios,usuales etc que hemos cargado desde los ficheros
' y voy eliminado aquellas palabras que aparezcan en el texto
on error resume next
for h=0 to ubound(tblArchivos)
stblDictionary=LoadDictArray(sPathFiles & tblArchivos(h))
for j = 0 to ubound(tblKeywords)
for i = 0 to ubound(stblDictionary)
if (lcase(tblKeywords(j))=lcase(stblDictionary(i))) then
tblKeywords(j)=""
end if
next
next
next
'Preparar las palabras para devolver
'for i=0 to ubound(tblKeywords)
if iKeyWLimit=0 then
iKeyWLimit=cint(ubound(tblKeywords))
end if
i=0
j=0
while (j<iKeyWLimit)
sTextoFinal = trim(sTextoFinal)
sKeyword = PrepForSpellCheck(tblKeywords(i))
if (sKeyword)<>"" then
j=j+1
'Comprobamos que la palabra no esté ya incluida y se repita
if (not instr(lcase(sTextofinal),lcase("," & sKeyword ))>0) then
sTextofinal=sTextoFinal & ", " & sKeyword
end if
end if
i=i+1
wend
sTextoFinal=right(sTextoFinal,len(sTextoFinal)-1)
getAutokeyWords=server.HTMLEncode(sTextoFinal)
end function
'////////////////////////////
'//// Autor: Jairo Blanco
'//// Fecha: 02/12/2004
'//// Descripción: Carga las palabras de un fichero en un array
'//// IN: Ruta del fichero a cargar
'//// OUT: Array con las palabras a filtrar
'///////////////////////////
Private function LoadDictArray(byVal cstRelativeDictPath)
Dim objFSO
Dim objDictFile
Dim intDictSize
Dim intForReading
Dim objDictStream
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objDictFile = objFSO.GetFile(Server.MapPath(cstRelativeDictPath))
intDictSize = objDictFile.Size
intForReading = 1
Set objDictStream = objDictFile.OpenAsTextStream(intForReading)
strDictArray = Split(objDictStream.Read(intDictSize), vbNewLine)
objDictStream.Close
Set objDictStream = Nothing
Set objDictFile = Nothing
Set objFSO = Nothing
loadDictArray=strDictArray
end function
'////////////////////////////
'//// Autor: Jairo Blanco
'//// Fecha: 02/12/2004
'//// Descripción: Comprueba los caracteres permitidos
'//// IN: Palabra a validar
'//// OUT: La misma palabra o vacio si no es válida.
'///////////////////////////
Private function PrepForSpellCheck(strWord)
Dim strValidChars
Dim i
Dim strLetter
strValidChars = "áéíóúabcdefghijklmnñopqrstuvwxyzÁÉÍÓÚABCDEFGHIJKLMNÑOPQRSTUVWXYZ1234567890"
for i = 1 to Len(strWord)
strLetter = Mid(strWord, i, 1)
if InStr(strValidChars, strLetter)> 0 then
PrepForSpellCheck = PrepForSpellCheck & strLetter
elseif i <Len(strWord) then
PrepForSpellCheck = ""
exit for
end if
next
end function
'////////////////////////////
'//// Autor: Fernando Blazquez
'//// Fecha: 03/07/2007
'//// Descripción: Elimina los acentos
'///////////////////////////
Private Function EliminarAcentos(texto)
dim i, s1, s2
s1 = "áàèéíïóòúü"
s2 = "aaeeiioouu"
if len(texto) <> 0 then
For i = 1 to Len(s1)
texto = replace(texto,mid(s1,i,1),mid(s2,i,1))
next
end if
EliminarAcentos = texto
End Function
'////////////////////////////
'//// Autor: Jairo Blanco
'//// Fecha: 02/12/2004
'//// Descripción: Elimina etiquetas HTML
'//// IN: Cadena en la que eliminar etiquetas HTML
'//// OUT: Cadena libre de código HTML
'///////////////////////////
Private Function StripHTML(byVal string)
set Reg = new RegExp
Reg.pattern = "[<][^>]*[>]"
Reg.IgnoreCase = true
Reg.Global = true
stripHTML = Reg.Replace(string,"")
StripHTML = Trim(string)
End Function
End Class
%>
autokeyword_v1.0.zip
Descargas: 334 en total
Loading ...
Mayo 11th, 2007 a las 2:32 pm
Justo lo que estaba buscando. Gracias de nuevo!
Mayo 18th, 2007 a las 3:03 pm
Jairo, esto habría que hacerlo para todas las noticias o simplemente con incluirlo en el top, me cogería para todas. que burro soy!!!
Mayo 23rd, 2007 a las 10:33 am
Hola Fran, eso depende de la técnica de cada uno. Hay gente que preferirá llamar a la función justo antes de mostrar cada noticia pasandole a la función la descripción+titulo de la noticia. Otros por el contrario tendrá un campo en la base de datos llamado “keywords” en el que almacenará esas keywords extraidas al llamar a la función justo antes de añadir una nueva noticia.
Julio 5th, 2007 a las 10:58 am
Gracias a Fernando por las correciones en el código.
Junio 13th, 2008 a las 11:20 am
una función muy util… pero no coje las palabras acentuadas. Probé comentando la llamada a la función EliminaAcentos, pero nada… no es que quiera incluir en las palabras clave palabras con acentos (que también…), me conformaria con que las incluya sin acentos, pero no se por qué se las salta… alguna solución? Gracias