module1.bas

经曲的字符串匹配模糊搜索算法 思想不是本人的

Attribute VB_Name = "Module1"
'说明：本函数用来求出两个字符之前的匹配度（介于0－1之前的一个浮点数），数值越大，两上字符越匹配

Public Function stringMatch(left As String, right As String) As Double
Dim leftsize As Integer
Dim rihgtsize As Integer
Dim maxsize As Integer
Dim matchval As Double
Dim CAP_MISMATCH_VAL As Double
Dim totalcount As Integer
Dim bestcount As Integer
Dim leftcount As Integer
Dim rightcout As Integer
Dim lpbest As Integer
Dim rkbest As Integer
Dim leftptr As Integer
Dim rightptr As Integer
Dim lp As Integer
Dim rp As Integer
'tmpstr1 As String
'tmpstr2 As String
CAP_MISMATCH_VAL = 0.9
matchval = 0#
leftptr = 1
rightptr = 1
leftsize = Len(left)
rightsize = Len(right)
If leftsize >= rightsize Then
    maxsize = leftsize
Else
    maxsize = rightsize
End If

If 2 * leftsize <= rightsize Or 2 * rightsize <= leftsize Then  '不到一半的提前退出循环
    stringMatch = 0
    Exit Function
End If

While (leftptr <> (leftsize + 1)) And (rightptr <> (rightsize + 1))
    If Mid(left, leftptr, 1) = Mid(right, rightptr, 1) Then
        matchval = matchval + 1# / maxsize
        leftptr = leftptr + 1
        rightptr = rightptr + 1
        'Debug.Print "matchval="; matchval
    ElseIf LCase(Mid(left, leftptr, 1)) = LCase(Mid(right, rightptr, 1)) Then
        matchval = matchval + CAP_MISMATCH_VAL / maxsize
        leftptr = leftptr + 1
        rightptr = rightptr + 1
    Else
        '以下是为找到最匹配的字符
        lpbest = leftsize + 1
        rpbest = rightsize + 1
        totalcount = 0
        bestcount = 1000
        leftcount = 0
        rightcount = 0
        For lp = leftptr To leftsize
            If (leftcount + rightcount) < bestcount Then
                For rp = rightptr To rightsize
                    If (leftcount + rightcount) < bestcount Then
                        If LCase(Mid(left, lp, 1)) = LCase(Mid(right, rp, 1)) Then  '这里我们不考虑大小写
                            totalcount = leftcount + rightcount
                            If totalcount < bestcount Then
                                bestcount = totalcount
                                lpbest = lp
                                rpbest = rp
                            End If
                        End If
                        rightcount = rightcount + 1
                    End If
                Next rp
                leftcount = leftcount + 1
                rightcount = 0
            End If
        Next lp
        leftptr = lpbest
        rightptr = rpbest
    End If
    
    Debug.Print "leftptr=" & leftptr & "  " & "rightptr=" & rightptr
    
    If (2 * leftptr >= leftsize And matchval <= 0.05) Or (2 * rightptr >= rightsize And matchval <= 0.05) Then '检测到一半如果没有匹配字符提前退出循环
        stringMatch = 0
        Exit Function
    End If
Wend
If matchval >= 0.95 Then
    matchval = 1#
ElseIf matchval <= 0.05 Then
    matchval = 0#
End If
stringMatch = matchval
End Function

'说明：本函数主要检测字符串right中是否有包含字符串left
'或字符串left中是否有包含字符串right
'若包含，则result=1，否则result＝0
'注：包含字符中不是完全包含，也就是说可以不是连在一起的字符
Public Function stringCoverMatch(left As String, right As String) As Integer

Dim leftsize As Integer
Dim rihgtsize As Integer
Dim leftptr As Integer
Dim rightptr As Integer
Dim count As Integer
Dim result As Integer
Dim tmpint As Integer
Dim tmpstr As String
leftptr = 1
rightptr = 1
count = 0
leftsize = Len(left)
rightsize = Len(right)
If leftsize > rightsize Then
    tmpstr = left
    left = right
    right = tmpstr
End If
tmpint = leftsize
leftsize = rightsize
rightsize = tmpint

While (leftptr <> (leftsize + 1))
    If LCase(Mid(left, leftptr, 1)) = LCase(Mid(right, rightptr, 1)) Then '忽略大写小
        leftptr = leftptr + 1
        rightptr = rightptr + 1
        count = count + 1
        If count = leftsize Then leftptr = leftsize + 1  '已找到匹配的，提前退出查询
    Else
        rightptr = rightptr + 1
        If rightptr = rightsize Then leftptr = leftsize + 1  '找不到匹配的，提前退出查询
    End If
Wend
If count = leftsize Then
    result = 1
Else
    result = 0
End If
stringCoverMatch = result
End Function