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