Metaphone Fucntion

Question

我想在Microsoft Access中使用metaphone算法进行模式匹配。我在http://www.snakelegs.org/2008/01/18/double-metaphone-visual-basic-implementation/上找到了一个代码但它不起作用，相反，Microsoft Access 2007挂起。

我尝试过soundex，但这还不足以达到我的目的。

任何帮助都会很明显......

Answer 1

@ Daredev，我无法直接回答您的问题，但可以通过VBA / Access中的示例直接找到有关模糊搜索的资源。不幸的是，他们都是德语：

Josef Syrovatka：http://access.primary.at/downloads/vortrag_syrovatka.zip
Michael Zimmermann：http://donkarl.com/Downloads/AEK/AEK13_Dubletten.zip

两者都是演示文稿和样本数据库。

Answer 2

我发现以下内容非常有用。首先，有三个版本的Metaphone -

音位
Double Metaphone
Metaphone V3

我在下面提供了Metaphone的代码。我发现它here，我编辑了一点代码。没有功能变化。

我还找到了一些enhanced version of soundex here。

如果您正在寻找double metaphone, visit here。它在Visual Basic中提供COM包装器，以语音方式搜索名称列表以及数据库表中的名称。

注意：请评论，上述哪种算法适用于您的场景。

Metaphone Fucntion

echo "These are tildes:  ~ and \~ and \\~"

主要功能从这里开始

Option Compare Database
Option Explicit

'Metaphone algorithm translated from C to Delphi by Tom White
'Translated to Visual Basic by Dave White 9/10/01
'
'v1.1 fixes a few bugs
'
' Checks length of string before removing trailing S (>1)
' PH used to translate to H, now translates to F

'Original C version by Michael Kuhn
'
'

这也是必要的

Function Metaphone(ByVal A As Variant) As String
Dim b, c, d, e As String
Dim inp, outp As String
Dim vowels, frontv, varson, dbl As String
Dim excppair, nxtltr As String
Dim T, ii, jj, lng, lastchr As Integer
Dim curltr, prevltr, nextltr, nextltr2, nextltr3 As String
Dim vowelafter, vowelbefore, frontvafter, silent, hard As Integer
Dim alphachr As String

On Error Resume Next
If IsNull(A) Then A = ""
A = CStr(A)
inp = UCase(A)
vowels = "AEIOU"
frontv = "EIY"
varson = "CSPTG"
dbl = "." 'Lets us allow certain letters to be doubled
excppair = "AGKPW"
nxtltr = "ENNNR"
alphachr = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"

'--Remove non-alpha characters
outp = ""
For T = 1 To Len(inp)
If InStr(alphachr, Mid(inp, T, 1)) > 0 Then outp = outp + Mid(inp, T, 1)
Next T

inp = outp: outp = ""

If Len(inp) = 0 Then Metaphone = "": Exit Function

'--Check rules at beginning of word
If Len(inp) > 1 Then
b = Mid(inp, 1, 1)
c = Mid(inp, 2, 1)
ii = InStr(excppair, b)
jj = InStr(nxtltr, c)
If ii = jj And ii > 0 Then
inp = Mid(inp, 2, Len(inp) - 1)
End If
End If

If Mid(inp, 1, 1) = "X" Then Mid(inp, 1, 1) = "S"

If Mid(inp, 1, 2) = "WH" Then inp = "W" + Mid(inp, 3)

If Right(inp, 1) = "S" Then inp = Left(inp, Len(inp) - 1)

ii = 0
Do
ii = ii + 1
'--Main Loop!
silent = False
hard = False
curltr = Mid(inp, ii, 1)
vowelbefore = False
prevltr = " "
If ii > 1 Then
prevltr = Mid(inp, ii - 1, 1)
If InStrC(prevltr, vowels) > 0 Then vowelbefore = True
End If

If ((ii = 1) And (InStrC(curltr, vowels) > 0)) Then
outp = outp + curltr
GoTo ContinueMainLoop
End If

vowelafter = False
frontvafter = False
nextltr = " "
If ii < Len(inp) Then
nextltr = Mid(inp, ii + 1, 1)
If InStrC(nextltr, vowels) > 0 Then vowelafter = True
If InStrC(nextltr, frontv) > 0 Then frontvafter = True
End If

'--Skip double letters EXCEPT ones in variable double
If InStrC(curltr, dbl) = 0 Then
If curltr = nextltr Then GoTo ContinueMainLoop
End If

nextltr2 = " "
If Len(inp) - ii > 1 Then
nextltr2 = Mid(inp, ii + 2, 1)
End If

nextltr3 = " "
If (Len(inp) - ii) > 2 Then
nextltr3 = Mid(inp, ii + 3, 1)
End If

Select Case curltr
Case "B":
silent = False
If (ii = Len(inp)) And (prevltr = "M") Then silent = True
If Not (silent) Then outp = outp + curltr
Case "C":
If Not ((ii > 2) And (prevltr = "S") And frontvafter) Then
If ((ii > 1) And (nextltr = "I") And (nextltr2 = "A")) Then
outp = outp + "X"
Else
If frontvafter Then
outp = outp + "S"
Else
If ((ii > 2) And (prevltr = "S") And (nextltr = "H")) Then
outp = outp + "K"
Else
If nextltr = "H" Then
If ((ii = 1) And (InStrC(nextltr2, vowels) = 0)) Then
outp = outp + "K"
Else
outp = outp + "X"
End If
Else
If prevltr = "C" Then
outp = outp + "C"
Else
outp = outp + "K"
End If
End If
End If
End If
End If
End If
Case "D":
If ((nextltr = "G") And (InStrC(nextltr2, frontv) > 0)) Then
outp = outp + "J"
Else
outp = outp + "T"
End If

Case "G":
silent = False
If ((ii < Len(inp)) And (nextltr = "H") And (InStrC(nextltr2, vowels) = 0)) Then
silent = True
End If
If ((ii = Len(inp) - 4) And (nextltr = "N") And (nextltr2 = "E") And (nextltr3 = "D")) Then
silent = True
ElseIf ((ii = Len(inp) - 2) And (nextltr = "N")) Then
silent = True
End If
If (prevltr = "D") And frontvafter Then silent = True
If prevltr = "G" Then
hard = True
End If

If Not (silent) Then
If frontvafter And (Not (hard)) Then
outp = outp + "J"
Else
outp = outp + "K"
End If
End If

Case "H":
silent = False
If InStrC(prevltr, varson) > 0 Then silent = True
If vowelbefore And (Not (vowelafter)) Then silent = True
If Not silent Then outp = outp + curltr

Case "F", "J", "L", "M", "N", "R": outp = outp + curltr

Case "K": If prevltr <> "C" Then outp = outp + curltr

Case "P": If nextltr = "H" Then outp = outp + "F" Else outp = outp + "P"

Case "Q": outp = outp + "K"

Case "S":
If ((ii > 2) And (nextltr = "I") And ((nextltr2 = "O") Or (nextltr2 = "A"))) Then
outp = outp + "X"
End If
If (nextltr = "H") Then
outp = outp + "X"
Else
outp = outp + "S"
End If

Case "T":
If ((ii > 0) And (nextltr = "I") And ((nextltr2 = "O") Or (nextltr2 = "A"))) Then
outp = outp + "X"
End If
If nextltr = "H" Then
If ((ii > 1) Or (InStrC(nextltr2, vowels) > 0)) Then
outp = outp + "0"
Else
outp = outp + "T"
End If
ElseIf Not ((ii < Len(inp) - 3) And (nextltr = "C") And (nextltr2 = "H")) Then
outp = outp + "T"
End If

Case "V": outp = outp + "F"

Case "W", "Y": If (ii < Len(inp) - 1) And vowelafter Then outp = outp + curltr

Case "X": outp = outp + "KS"

Case "Z": outp = outp + "S"

End Select
ContinueMainLoop:
Loop Until (ii > Len(inp))

Metaphone = outp

End Function

如何在Microsoft访问中实现metaphone？

2 个答案:

Metaphone Fucntion