Hola a todos, os presento mi utlima funcion :
Check_Similar_Words
- ¿Que hace?
Busca palabras similares en una cadena de texto, obtendrias un resultado similar al tipico de Google : "Quizas quiso decir... "
- ¿Como funciona?
Lo que hace es alamcenar en un array todas las palabras que encuentre en la cadena a analizar, una vez aqui, descompongo la palabra que se busca en las partes correspondientes a el número de coincidencias que queramos buscar, os voy a poner un ejemplo:
Supongamos que se desea buscar la palabra "mañana", y indicamos a la funcion que busque palabras similares con 3 coincidencias, entonces se partiria la palabra a buscar de esta manera:
Citarmañ
aña
ñan
ana
La formula para sacar el numero de fragmentos es esta:
(x - n) + 1Donde
x es la cantidad de digitos de la palabra y
n los digitos en los que se quiere separar esa palabra... :D
Comprobaria si las palabras de la cadena contienen algunos de estos trozos y las guarda en mi
Collection.
Lo divertido es que segun el número de coincidencias que pongamos, la busqueda sera mas o menos estricta. :laugh:
- Bueno aqui os dejo el codigo:
'==================================================================================================
' º Function : Check_Similar_Words
' º Version : 1.2
' º Author : Mr.Frog ©
' º Country : Spain
' º Mail : vbpsyke1@mixmail.com
' º Twitter : http://twitter.com/#!/PsYkE1
' º Recommended Websites :
' http://visual-coders.com.ar
' http://InfrAngeluX.Sytes.Net
'==================================================================================================
Option Explicit
Option Base 0
Private Declare Function lstrcmpi Lib "kernel32" Alias "lstrcmpiA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Public Function Check_Similar_Words(ByVal sStringToAnalyze As String, ByVal sWord As String, ByVal bvComparationLevel As Byte) As Collection
Const sNullChars As String = ".,"
Dim cTemp As New Collection
Dim sCompareWord() As String
Dim sTextWord() As String
Dim sActualWord As String
Dim lTotalCompWords As Long
Dim lTotalWords As Long
Dim lLenWord As Long
Dim Q As Long
Dim G As Long
If CBool(bvComparationLevel) Then
lLenWord = Len(sWord)
If (lLenWord > 2) And (Len(sStringToAnalyze) > lLenWord) Then
If (bvComparationLevel < lLenWord) Then
If Not (InStrB(sWord, vbNewLine)) Then
G = 1
lTotalCompWords = (lLenWord - bvComparationLevel) + 1
ReDim sCompareWord(lTotalCompWords) As String
Do Until Q = lTotalCompWords
sCompareWord$(Q) = Mid$(sWord, G, bvComparationLevel)
G = G + 1
Q = Q + 1
Loop
sStringToAnalyze = Replace$(sStringToAnalyze, vbNewLine, Space$(1))
sTextWord() = Split(sStringToAnalyze, Space$(1))
lTotalWords = UBound(sTextWord)
lTotalCompWords = lTotalCompWords - 1
For Q = 0 To lTotalWords
sActualWord = sTextWord(Q)
If Len(sActualWord) >= bvComparationLevel Then
For G = 0 To lTotalCompWords
If CBool(lstrcmpi(sWord, sActualWord)) Then
If InStrB(1, sActualWord, sCompareWord(G), vbTextCompare) Then
If InStrB(sNullChars$, Right$(sActualWord, 1)) Then
sActualWord = Left$(sActualWord, Len(sActualWord) - 1)
End If
On Error Resume Next
cTemp.Add sActualWord, sActualWord
End If
End If
Next G
End If
Next Q
Set Check_Similar_Words = cTemp
End If
End If
End If
End If
End Function- Un ejemplo práctico:
Tengo en un TextBox(llamado Text1) esto:
Citar
La inspiración de Cervantes para componer esta obra vino, al parecer, del llamado Entremés de los romances, que era de fecha anterior (aunque esto es discutido). Su argumento ridiculiza a un labrador que enloquece creyéndose héroe de romances. El labrador abandonó a su mujer, y se echó a los caminos, como hizo Don Quijote. Este entremés posee una doble lectura: también es una crítica a Lope de Vega; quien, después de haber compuesto numerosos romances autobiográficos en los que contaba sus amores, abandonó a su mujer y marchó a la Armada Invencible. Es conocido el interés de Cervantes por el Romancero y su resentimiento por haber sido echado de los teatros por el mayor éxito de Lope de Vega, así como su carácter de gran entremesista. Un argumento a favor de esta hipótesis sería el hecho de que, a pesar de que el narrador nos dice que Don Quijote ha enloquecido a causa de la lectura de libros de caballerías, durante su primera salida recita romances constantemente, sobre todo en los momentos de mayor desvarío. Por todo ello, podría ser una hipótesis verosímil. A este influjo se agregó el de Tirante el Blanco de Joanot Martorell, el del Morgante de Luigi Pulci y el del Orlando Furioso de Ludovico Ariosto.
Para ver un ejemplo:
Private Sub Form_Load()
Dim vItem As Variant
Debug.Print "--------------->"; Time$
For Each vItem In Check_Similar_Words(Text1.Text, "argumento", 4)
Debug.Print vItem
Next vItem
End SubY obtengo esto:
Citar
Entremés
numerosos
resentimiento
entremesista
constantemente
momentos
En cambio si en vez de
3 pongo
4 en la llamada la busqueda de palabras similares se vuelve más extricta y obtendria esto:
Citar
resentimiento
constantemente
momentos
Espero que os haya gustado! :-*
Salu2! :P
Muy interesante, ;-)
Saludos :)
Atención:
He corregido testeado y optimizado el Source!!! :P
Salu2! ;)
Lo probaré, porque no me ha quedado del todo claro.
Ok, ¿que es lo que no te quedo claro?
Salu2! ;)
Una de las cosas es lo que ponía antes de que lo corrigieras, ahora si.
Ya lo he pillado..
Mira he puesto esto:
Text1-> Lo que hace es alamcenar en un array todas las palabras que encuentre en la cadena a analizar, una vez aqui, descompongo la palabra que se busca en las partes correspondientes a el número de coincidencias que queramos buscar, os voy a poner un ejemplo:
sWord -> "enjambre" ---->si lComparationLevel = 1 --->la palabra que sale es "ejemplo"
---->si lComparationLevel = 2 --->la palabra que sale es "queramos"
Un poco raro xD pero bueno ;)
:P Buen code.
Revisa el
SRC que lo he cambiado 30 veces despues de postearlo... :xD
No me sale lo mismo que a ti... :-\
Me sale esto si pongo 1:
Citar
que
hace
es
alamcenar
en
un
array
todas
las
palabras
encuentre
la
cadena
a
analizar
una
vez
aqui
descompongo
palabra
se
busca
partes
correspondientes
el
número
de
coincidencias
queramos
buscar
poner
ejemplo
Y si pongo 2:
Citaralamcenar
en
palabras
encuentre
cadena
palabra
correspondientes
coincidencias
queramos
No obstante poner los valores
1 o
2, es una chorrada, porque el nivel de exigencia seria demasiado bajo... :¬¬
Corregi el
SRC, ahora solo se puede poner el valor
3 como minimo... :P
Salu2 y Gracias! ;)
MIra esto
http://en.wikipedia.org/wiki/Levenshtein_distance
aaahh ya lo pillo yo tengo puesto esto en mi code:
Private Sub Form_Load()
Dim vItem As Variant
Dim sString As String
sString = Text1.Text
For Each vItem In Check_Similar_Words(sString, "agua", 1)
Debug.Print vItem
Text2.Text = vItem
Next vItem
End SubCitarText2.Text = vItem
ese es el error, como lo pones tú?
Cita de: Komodo en 2 Julio 2010, 16:00 PM
aaahh ya lo pillo yo tengo puesto esto en mi code:
Private Sub Form_Load()
Dim vItem As Variant
Dim sString As String
sString = Text1.Text
For Each vItem In Check_Similar_Words(sString, "agua", 1)
Debug.Print vItem
Text2.Text = vItem
Next vItem
End Sub
CitarText2.Text = vItem
ese es el error, como lo pones tú?
NoO0 :xD
Text2?? :huh:
Actualmente si abres un proyecto y copias y pegas el codigo funciona bien, no tienes que cambiar nada... :P
Cita de: cobein en 2 Julio 2010, 15:40 PM
MIra esto
http://en.wikipedia.org/wiki/Levenshtein_distance
Wow! :o
Me parece interesantisimo!! ;-)
Al hacer la funcion me tuve yo que inventar el logaritmo... :silbar:
Salu2! ;)
Lo he copiado y eso del Debug no me va ;D
como hago que salga???
Lo deberias de ver en una pestaña llamada Inmediato, que aparece al ejecutar un proyecto, mira:
(http://toyscaos.tripod.com/puntero2.jpg)
Salu2! ;)
EPIC FAIL
Excelente Psyke1...! Buen codigo...! ;D
Código actualizado de nuevo, ahora con más velocidad...
Iré implementando más opciones en los próximos días. ;)
DoEvents! :P
Esta Bueno