Microsoftのアクセスでメタフォンを実装する方法は？

Question

Microsoft Accessでパターンマッチングにメタフォンアルゴリズムを使用したいと思います。 http://www.snakelegs.org/2008/01/18/double-metaphone-visual-basic-implementation/ にコードが1つ見つかりましたが、動作しません。代わりに、Microsoft Access 2007がハングアップします。

私はsoundexを試しましたが、私の目的は十分ではありません。

すべてのヘルプはかなりのだろう...

Answer 1

@Daredev、私が直接あなたの質問に答えることはできませんが、VBA /アクセスの例とあいまい検索に関するリソースに指示することができます。残念ながら、それらはすべてドイツ語である：

• ヨーゼフSyrovatka：http://access.primary.at/downloads/vortrag_syrovatka.zip
• マイケル・ツィンマーマン：http://donkarl.com/Downloads/AEK/AEK13_Dubletten.zip

は両方のサンプルデータベースと一緒にプレゼンテーションしています。

Answer 2

次のことがわかりました。

1. Metaphoneの
2. ダブルMetaphoneの
3. MetaphoneのV3私はMetaphoneのためのコードの下に設けられている

- まず第一に、Metaphoneのの3つのバージョンがあります。 hereが見つかりました。コードを少し編集しました。機能の変更はありません。

私はまた、enhanced version of soundex hereを見つけました。

double metaphone, visit hereをお探しの場合は、 Visual Basic内のCOMラッパーを使用して、データベーステーブルの名前だけでなく名前の一覧も音声で検索します。

注：あなたのシナリオでは、上記のアルゴリズムのどれがうまくいきましたか、ご意見ください。

MetaphoneのFucntion

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 

を開始これは

Function InStrC(ByVal SearchIn As String, ByVal SoughtCharacters As String) As Integer 
'--- Returns the position of the first character in SearchIn that is contained 
'--- in the string SoughtCharacters. Returns 0 if none found. 
Dim i As Integer 

On Error Resume Next 
SoughtCharacters = UCase(SoughtCharacters) 
SearchIn = UCase(SearchIn) 
For i = 1 To Len(SearchIn) 
If InStr(SoughtCharacters, Mid(SearchIn, i, 1)) > 0 Then 
InStrC = i: Exit Function 
End If 
Next i 
InStrC = 0 
End Function