LEADERSOFT.ru Разработка на заказ программ и сайтов
Раздел обучения информационным технологиям
Разработка программ на Access
03. Есть таблица, в ней нужно провести поиск. При этом известно, что пользователь не знает Русского языка и допускает ошибки в словах. Этот пример решает такую проблему.
Свойства продукта

 Microsoft Office: 2000,2002,2003,2007,2010  Архив с файлами: Перейти
 Операционная система: Windows XP,Vista  Применение: Базы данных Access
 Продажа: Купить  Файл исходника: ..\Access\10 Поиск\la_find.mdb
 Язык интерфейса: Русский

   

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 LongAs 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 LongAs RetCount
Dim tret As RetCount
Dim 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


Copyright © 2002-2015 ООО Лидер Эксэсс
Сайт работает под управлением: ASP.NET, Access