Results 1 to 7 of 7

Thread: [SRC] + [Function] Check_Similar_Words [by *PsYkE1*]

  1. #1

    Thread Starter
    Addicted Member *PsyKE1*'s Avatar
    Join Date
    Jun 2010
    Location
    Spain
    Posts
    243

    Thumbs up [SRC] + [Function] Check_Similar_Words [by *PsYkE1*]

    Hi all, I present my last function: Check_Similar_Words

    What does
    Search for similar words in a text string, you will get a result similar to typical Google: "Did you mean ..."

    How it works
    What it does is storage in an array all the words it finds in the string to be parsed once here, decompose the word to search for in the shares of the number of matches we want to look, I'll give you an example:
    Suppose you want to find the word "little" and tells the function to look for similar words with three matches, then split the word to look like this:

    lit
    itt
    ttl
    tle
    The formula to get the number of fragments is:

    Code:
    (X - n) + 1
    Where x is the number of digits of the word n the digits in which you want to spread the word ... : D

    Would check if the words of the string containing some of these pieces and would get into a Collection.
    The funny thing is that according to the number of matches to say, the search will be more or less strict.

    vb Code:
    1. '==================================================================================================
    2. ' º Function *: Check_Similar_Words
    3. ' º Version * : 1.2
    4. ' º Author * *: Mr.Frog ©
    5. ' º Country * : Spain
    6. ' º Mail * * *: vbpsyke1@mixmail.com
    7. ' º Twitter * : http://twitter.com/#!/PsYkE1
    8. ' º Recommended Websites :
    9. ' * * * http://visual-coders.com.ar
    10. ' * * * http://InfrAngeluX.Sytes.Net
    11. '==================================================================================================
    12.  
    13. Option Explicit
    14. Option Base 0
    15.  
    16. Private Declare Function lstrcmpi Lib "kernel32" Alias "lstrcmpiA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
    17.  
    18. Public Function Check_Similar_Words(ByVal sStringToAnalyze As String, ByVal sWord As String, ByVal bvComparationLevel As Byte) As Collection
    19. Const sNullChars * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *As String = ".,"
    20. Dim cTemp * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * As New Collection
    21. Dim sCompareWord() * * * * * * * * * * * * * * * * * * * * * * * * * * * * *As String
    22. Dim sTextWord() * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * As String
    23. Dim sActualWord * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * As String
    24. Dim lTotalCompWords * * * * * * * * * * * * * * * * * * * * * * * * * * * * As Long
    25. Dim lTotalWords * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * As Long
    26. Dim lLenWord * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *As Long
    27. Dim Q * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * As Long
    28. Dim G * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * As Long
    29.  * *
    30.  * *If CBool(bvComparationLevel) Then
    31.  * * * *lLenWord = Len(sWord)
    32.  * * * *If (lLenWord > 2) And (Len(sStringToAnalyze) > lLenWord) Then
    33.  * * * * * *If (bvComparationLevel < lLenWord) Then
    34.  * * * * * * * *If Not (InStrB(sWord, vbNewLine)) Then
    35.  * * * * * * * * * *G = 1
    36.  * * * * * * * * * *
    37.  * * * * * * * * * *lTotalCompWords = (lLenWord - bvComparationLevel) + 1
    38.  * * * * * * * * * *ReDim sCompareWord(lTotalCompWords) As String
    39.  * * * * * * * * * *
    40.  * * * * * * * * * *Do Until Q = lTotalCompWords
    41.  * * * * * * * * * * * *sCompareWord$(Q) = Mid$(sWord, G, bvComparationLevel)
    42.  * * * * * * * * * * * *G = G + 1
    43.  * * * * * * * * * * * *Q = Q + 1
    44.  * * * * * * * * * *Loop
    45.  * * * * * * * * * *
    46.  * * * * * * * * * *sStringToAnalyze = Replace$(sStringToAnalyze, vbNewLine, Space$(1))
    47.  * * * * * * * * * *sTextWord() = Split(sStringToAnalyze, Space$(1))
    48.  * * * * * * * * * *
    49.  * * * * * * * * * *lTotalWords = UBound(sTextWord)
    50.  * * * * * * * * * *lTotalCompWords = lTotalCompWords - 1
    51.  * * * * * * * * * *
    52.  * * * * * * * * * *For Q = 0 To lTotalWords
    53.  * * * * * * * * * * * *sActualWord = sTextWord(Q)
    54.  * * * * * * * * * * * *If Len(sActualWord) >= bvComparationLevel Then
    55.  * * * * * * * * * * * * * *For G = 0 To lTotalCompWords
    56.  * * * * * * * * * * * * * * * If CBool(lstrcmpi(sWord, sActualWord)) Then
    57.  * * * * * * * * * * * * * * * * * *If InStrB(1, sActualWord, sCompareWord(G), vbTextCompare) Then
    58.  * * * * * * * * * * * * * * * * * * * *If InStrB(sNullChars$, Right$(sActualWord, 1)) Then
    59.  * * * * * * * * * * * * * * * * * * * * * *sActualWord = Left$(sActualWord, Len(sActualWord) - 1)
    60.  * * * * * * * * * * * * * * * * * * * *End If
    61.  * * * * * * * * * * * * * * * * * * * *On Error Resume Next
    62.  * * * * * * * * * * * * * * * * * * * *cTemp.Add sActualWord, sActualWord
    63.  * * * * * * * * * * * * * * * * * *End If
    64.  * * * * * * * * * * * * * * * *End If
    65.  * * * * * * * * * * * * * *Next G
    66.  * * * * * * * * * * * *End If
    67.  * * * * * * * * * *Next Q
    68.  * * * * * * * * * *
    69.  * * * * * * * * * *Set Check_Similar_Words = cTemp
    70.  * * * * * * * *End If
    71.  * * * * * *End If
    72.  * * * *End If
    73.  * *End If
    74. End Function

    A practical example:

    I have a TextBox (named Text1) this:
    Cervantes's inspiration to compose this work came, apparently, the so-called Romance, which was earlier (although this is disputed). His argument ridicules believing a farmer who goes mad hero of romance. The farmer left his wife, and fell to the roads, as did Don Quixote. This appetizer has a double reading: it is also a criticism of Lope de Vega, who, after having written many autobiographical romances where it had his love, left his wife and went to the Armada. Interest is known by the ballads of Cervantes and his resentment at being kicked out of the theaters by the most successful of Lope de Vega, and whether they are of great appetizers. One argument in favor of this hypothesis would be that, despite the narrator tells us that Don Quixote is mad because of reading books of chivalry, in his first start romances recited constantly, especially in times of more madness. Therefore, it could be a plausible hypothesis. To this was added the influence of the White Joanot Tirante Martorell, that of Pulci Morgante of Luigi and the Orlando Furioso of Ludovico Ariosto.
    I make a call like this:

    vb Code:
    1. Private Sub Form_Load()
    2.     Dim vItem         As Variant
    3.  
    4.     Debug.Print "--------------->"; Time$
    5.     For Each vItem In Check_Similar_Words(Text1.Text, "argumento", 3)
    6.         Debug.Print vItem
    7.     Next vItem
    8. End Sub

    And get this in the ListBox:
    apparently
    went
    resentment
    In contrast, if instead of 3 in the call put 4 the search becomes more similar words strictest and obtain this:
    resentment
    I hope you liked it! : -*

    Sorry for my English, becouse I'm spanish...
    Last edited by *PsyKE1*; Feb 23rd, 2011 at 01:56 PM.

  2. #2
    Next Of Kin baja_yu's Avatar
    Join Date
    Aug 2002
    Location
    /dev/root
    Posts
    5,989

    Re: [SRC] + [Function] Check_Similar_Words [by *PsYkE1*]

    Hi and welcome to the forum.

    I didn't test your code, but I like the description of what it is supposed to do. I'll give it a try later (don't have VB6 at the moment).

    I just have two comments. First, the formating is a bit of with [/code] and [/quote] tags, a few line breaks also. Two, this section of the forum is mainly for asking questions and getting help. If you want to share some function or working code you made, you should look into the CodeBank section that is set up just for that. I'll notify the mods to move it there for you.

    Keep up the good work!

    EDIT: Comment #3, you might want to remove your e-mail address from the post, as spammers have bots that scavange websites and forums for email addresses. Publishing it like that is a good way of ending up on a spammers list and getting tons of it.

  3. #3

    Thread Starter
    Addicted Member *PsyKE1*'s Avatar
    Join Date
    Jun 2010
    Location
    Spain
    Posts
    243

    Re: [SRC] + [Function] Check_Similar_Words [by *PsYkE1*]

    hahahaha ok
    sorry for the mistakes, will not happen again, I would like you to give me your opinion after that you test it, &#191;ok?
    See you

    EDIT: i fixed what you told me
    Last edited by *PsyKE1*; Jun 3rd, 2010 at 08:23 PM.

  4. #4
    Next Of Kin baja_yu's Avatar
    Join Date
    Aug 2002
    Location
    /dev/root
    Posts
    5,989

    Re: [SRC] + [Function] Check_Similar_Words [by *PsYkE1*]

    Don't worry about it. There are a lot of sections on the forums so it takes some time to get used to. I'll post my comments as soon as I give it a try.

  5. #5
    I'm about to be a PowerPoster! Hack's Avatar
    Join Date
    Aug 2001
    Location
    Searching for mendhak
    Posts
    58,333

    Re: [SRC] + [Function] Check_Similar_Words [by *PsYkE1*]

    Moved To The CodeBank

  6. #6

    Thread Starter
    Addicted Member *PsyKE1*'s Avatar
    Join Date
    Jun 2010
    Location
    Spain
    Posts
    243

    Re: [SRC] + [Function] Check_Similar_Words [by *PsYkE1*]

    I tested the function and I corrected mistakes so please try it!

    Bye

  7. #7

    Thread Starter
    Addicted Member *PsyKE1*'s Avatar
    Join Date
    Jun 2010
    Location
    Spain
    Posts
    243

    Re: [SRC] + [Function] Check_Similar_Words [by *PsYkE1*]

    I have greatly improved function. Especially the speed.
    See it again please and give me your opinion.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width