Attribute VB_Name = "mdl_stringZADE"
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 Type UDK
    ul As String
    dom As String
    kv As String
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


Public Sub test_sz()
Dim s As String
Dim s2 As String
Dim k As Long
Dim l As Long
Dim adresa As UDK
s = "ЛЕНИГРАДСКАЯ 11-4"
adresa = uldomkv(s)
Debug.Print adresa.ul, adresa.dom, adresa.kv
s2 = "Ленинградская"
k = 3
l = 1
If (IndistinctMatching(k, adresa.ul, s2, l)) > 65 Then
adresa.ul = s2
End If
Debug.Print adresa.ul, "dom." & adresa.dom, "kv." & adresa.kv
End Sub

Public Function uldomkv(inadr As String, Optional d As String = " ") As UDK
'разделим inadr
Dim s1 As String
Dim s2 As String
Dim s3 As String
Dim i As Integer
Dim k1, k2 As Integer
'выделяем улицу до первого пробела
k1 = InStr(1, inadr, d)
k2 = InStr(k1 + 1, inadr, d)
With uldomkv
.ul = Mid(inadr, 1, k1)
.dom = RTrim(LTrim(Mid(inadr, k1 + 1, IIf(k2 = 0, Len(inadr), k2) - k1)))
If k2 > 0 Then
.kv = RTrim(LTrim(Mid(inadr, k2, Len(inadr))))
Else
.kv = ""
End If
End With
End Function