Foro de elhacker.net

• ¿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:
  

(x - n) + 1

• 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 Sub

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