Re: Use of Soundex fields in access

In article <1154379009.560602.216620@xxxxxxxxxxxxxxxxxxxxxxxxxxxx>,
vonclausowitz@xxxxxxxxx says...
You can have it no problem,

if you could just send me the Metaphome Algoritm in return, thanks:

OK, here it is. I have seen places on the Internet where the advantages
and disadvantages of various Soundex-like algorithms are discussed. It
just depends on the types of names that need to be encoded.

Option Compare Database
Option Explicit

'Metaphone algorithm translated from C to Delphi by Tom White <w...
@intellex.com>
'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 <rhlab!mk...@xxxxxxxxxxxx>
'
'
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

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

.

Relevant Pages

  • Re: Passing the resulting variable to a file
    ... response file that is used to silently install the software. ... Dim WSHShell ... setup.iss and makes the software possible to install in silent mode. ...
    (microsoft.public.scripting.vbscript)
  • Re: Vamos a hablar claro
    ... though with the silent /h/. ... Then all of the rest of this "dim" business had ... next time be more careful when using the word ...
    (sci.lang)
  • Re: Paging JB and the lowvoltageelectricitylightingisti
    ... silent on full, raising to rather noisy in the mid brightness down to ... Is this a problem that I'll face with all dimmers, or are there any on the ... Some if not all 'domestic' dimmers make some audible noise at lower dim ...
    (uk.rec.motorcycles)
  • Re: Vamos a hablar claro
    ... Harlan Messinger wrote: ... though with the silent /h/. ... Then all of the rest of this "dim" business had ...
    (sci.lang)
  • Re: C Code "sanity checking" tools
    ... string happens to be a null string, or where a buffer overrun is silent. ... That's right, the code we actually had a problem with passed system testing, user acceptance testing and had been running live for a couple of years without a problem being noticed. ...
    (comp.unix.programmer)