Option Compare Database
Option Explicit

'   ,   
': Example 03
'
'    vlak@glasnet.ru
'http://www.glasnet.ru/~vlak/similar/similar.html
'
':  , malnik@mail.ru
'
'lngMaxLen -    ( 3-4)
'strStringMatching -  
'strStringStandart - -
'

Private Type RetCount
    lngSubRows As Long
    lngCountLike As Long
End Type

Public Function IndistinctMatching(lngMaxLen As Long, strStringMatching As String, strStringStandart As String, lngCase As Long) As Long
Dim gret As RetCount
Dim tret As RetCount
Dim lngCurLen As Long   '  

    '   - ,  
    If lngMaxLen = 0 Or Len(strStringMatching) = 0 Or Len(strStringStandart) = 0 Then
        IndistinctMatching = 0
        Exit Function
    End If
    
    gret.lngCountLike = 0
    gret.lngSubRows = 0
    For lngCurLen = 1 To lngMaxLen
        '  A   B
        tret = MatchingStrings(strStringMatching, strStringStandart, lngCurLen, lngCase)
        gret.lngCountLike = gret.lngCountLike + tret.lngCountLike
        gret.lngSubRows = gret.lngSubRows + tret.lngSubRows
        '  B   A
        tret = MatchingStrings(strStringStandart, strStringMatching, lngCurLen, lngCase)
        gret.lngCountLike = gret.lngCountLike + tret.lngCountLike
        gret.lngSubRows = gret.lngSubRows + tret.lngSubRows
    Next lngCurLen
    
    If gret.lngSubRows = 0 Then
        IndistinctMatching = 0
        Exit Function
    End If
    IndistinctMatching = (gret.lngCountLike / gret.lngSubRows) * 100
End Function

Private Function MatchingStrings(strA As String, strB As String, lngLen As Long, lngCase As Long) As RetCount
Dim tret As RetCount
Dim y As Long, z As Long
Dim strta As String
Dim strtb As String
    For z = 1 To Len(strA) - lngLen + 1
       strta = Mid(strA, z, lngLen)
       y = 1
       For y = 1 To Len(strB) - lngLen + 1
          strtb = Mid(strB, y, lngLen)
          If StrComp(strta, strtb, lngCase) = 0 Then
          tret.lngCountLike = tret.lngCountLike + 1
          Exit For
          End If
       Next y
    tret.lngSubRows = tret.lngSubRows + 1
    Next z
    MatchingStrings.lngCountLike = tret.lngCountLike
    MatchingStrings.lngSubRows = tret.lngSubRows
End Function
