[SRC] Check_Similar_Words [by Mr. Frog ©]

[Psyke1]

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:
  

mañ
aña
ñan
ana

La formula para sacar el numero de fragmentos es esta:

Código [Seleccionar] Expandir


(x - n) + 1
Donde x es la cantidad de digitos de la palabra y n los digitos en los que se quiere separar esa palabra...

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.

• Bueno aqui os dejo el codigo:

Código (vb) [Seleccionar] Expandir


'==================================================================================================
' º 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:
  

  
  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:
  

Código (vb) [Seleccionar] Expandir


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 Sub

Y obtengo esto:

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:

resentimiento
constantemente
momentos

Espero que os haya gustado!

Salu2!

[e500]

Muy interesante, 

Saludos

[Psyke1]

Atención:
He corregido testeado y optimizado el Source!!!

Salu2!

[Komodo]

Lo probaré, porque no me ha quedado del todo claro.

[Psyke1]

Ok, ¿que es lo que no te quedo claro?

Salu2!

[Komodo]

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

Buen code.

[Psyke1]

Revisa el SRC que lo he cambiado 30 veces despues de postearlo...
No me sale lo mismo que a ti...

Me sale esto si pongo 1:

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:

alamcenar
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...

Salu2 y Gracias!

[cobein]

MIra esto
http://en.wikipedia.org/wiki/Levenshtein_distance

[Komodo]

aaahh ya lo pillo yo tengo puesto esto en mi code:

Código (vb) [Seleccionar] Expandir

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

Text2.Text = vItem

ese es el error, como lo pones tú?

[Psyke1]

aaahh ya lo pillo yo tengo puesto esto en mi code:

Código (vb) [Seleccionar] Expandir

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

Text2.Text = vItem

ese es el error, como lo pones tú?

NoO0
Text2??  
Actualmente si abres un proyecto y copias y pegas el codigo funciona bien, no tienes que cambiar nada...

MIra esto
http://en.wikipedia.org/wiki/Levenshtein_distance

Wow!
Me parece interesantisimo!!
Al hacer la funcion me tuve yo que inventar el logaritmo...

Salu2!