2

I want to use metaphone algorithm for pattern matching in Microsoft Access. I found one code on http://www.snakelegs.org/2008/01/18/double-metaphone-visual-basic-implementation/ but it doesn't works, instead, Microsoft Access 2007 hangs up.

I have tried soundex, but it doesn't suffice my purpose.

Any help would be appreciable...

Joel Coehoorn
  • 399,467
  • 113
  • 570
  • 794
Viral Jain
  • 1,004
  • 1
  • 14
  • 30
  • 2
    "It doesn't work" -- what doesn't work? What have you attempted to do and what errors have you encountered? – David-W-Fenton Jul 15 '11 at 19:33
  • @David-W-Fenton:The code given on the URL doesn't work; When I run it, Microsoft Access hangs up... (may be due to 1600X30 fields in the table & inner join as well) No errors as such – Viral Jain Jul 18 '11 at 08:58
  • 1
    Try this one: http://www.codeguru.com/vb/gen/vb_misc/tips/article.php/c13137__2/#more – Robert Harvey Nov 26 '11 at 20:17
  • @RobertHarvey: Well, can i execute/call these functions through php code? – Viral Jain Nov 26 '11 at 20:28
  • Erm... How would that work? VBA is a desktop application language, PHP is a web language, and if you're using Access as a backend for a website, there are better alternatives. – Robert Harvey Nov 26 '11 at 21:49
  • @RobertHarvey: SIr, that's why I asked the question, albeit I forgot to menion php frontend. Well, which alternatives are you talking about? – Viral Jain Nov 27 '11 at 08:16

2 Answers2

3

@Daredev, I cannot directly answer your question, but can direct to resources regarding fuzzy search with examples in VBA/Access. Unfortunately they are all in German:

Both are presentations along with sample databases.

paulroho
  • 1,234
  • 1
  • 11
  • 27
0

I found the following very useful. First of all, there are 3 versions of Metaphone -

  1. Metaphone
  2. Double Metaphone
  3. Metaphone V3

I have provided below the code for Metaphone. I found it here, I edited the code a little. No functional change.

I have also found some enhanced version of soundex here.

If you are looking for double metaphone, visit here . It provides COM wrapper within Visual Basic to phonetically search a list of names, as well as names in a database table.

NOTE : Please comment, which of the mentioned algorithm worked well for your scenario.

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
'
'

Main function starts here

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

This is also necessary

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
Adarsh Madrecha
  • 6,364
  • 11
  • 69
  • 117