Public Function Soundex(ByVal WordStr As String) As String
Dim str_Word As String
Dim i As Long
Dim c As String
Dim s As String
Dim d As String
Dim f As String
Dim let1 As String
Dim wrd As String
Dim metaph As String
' 1. Encode the letters, starting with the 2nd letter. '
' 2. If two adjacent letters have the same soundex code, '
' treat them as one. '
' 3. If two consonants are separated by a vowel or Y, use '
' both consonants. '
' 4. If two consonants are separated by H or W, treat '
' them as one. (I.e. rule 3 applies.) '
str_Word = UCase$(Trim$(WordStr))
If str_Word = "" Then Exit Function
For i = 1 To Len(str_Word)
c = Mid(str_Word, i, 1)
f = c
' Convert non-US characters:
If InStr("ÀÁÂÃÄÅ«", c) > 0 Then
f = "A"
ElseIf c = "Ç" Then
f = "C"
ElseIf InStr("ÈÉÊË", c) > 0 Then
f = "E"
ElseIf InStr("ÌÍÎÏ", c) > 0 Then
f = "I"
ElseIf c = "Ñ" Then
f = "N"
ElseIf InStr("ÒÓÔÕÖ", c) > 0 Then
f = "O"
ElseIf InStr("ÙÚÛÜ", c) > 0 Then
f = "U"
ElseIf c = "Ý" Then
f = "Y"
End If
If c <> f Then Mid$(str_Word, i, 1) = f
' Get rid of non-alpha characters: '
' (e.g.: o'clock -> oclock) '
If (Not (c Like "[A-Z]")) Then
str_Word = Replace(str_Word, c, " ")
End If
Next i
str_Word = Replace$(str_Word, " ", "")
If str_Word = "" Then Exit Function
' Change starting letters to actual sounds: '
s = Left$(str_Word, 2)
If s = "PS" Or s = "PN" Or s = "KN" Or s = "GN" Or s = "WR" Then
str_Word = Mid(str_Word, 2)
ElseIf Left$(str_Word, 3) = "WHO" Then
str_Word = "H" & Mid$(str_Word, 3)
ElseIf s = "WH" Then
str_Word = "W" & Mid$(str_Word, 3)
ElseIf s = "PH" Then
str_Word = "F" & Mid$(str_Word, 3)
ElseIf Left$(str_Word, 1) = "X" Then
str_Word = "Z" & Mid$(str_Word, 2)
End If
' Metaphone changes: '
' When swapping letters for numbers, "c" '
' is treated as a sibilant, not as a "k".'
str_Word = Replace$(str_Word, "STLE", "SEL") ' whistle - the t is silent '
str_Word = Replace$(str_Word, "SCLE", "SEL") ' muscle - the c is silent '
str_Word = Replace$(str_Word, "CK", "K") ' rack, flock - the c is silent '
str_Word = Replace$(str_Word, "CT", "KT") ' doctor - the c is hard '
str_Word = Replace$(str_Word, "SCIE", "SIE") ' science - the c is silent '
str_Word = Replace$(str_Word, "SCE", "SE") ' scene - the c is silent '
str_Word = Replace$(str_Word, "SCY", "SY")
str_Word = Replace$(str_Word, "SC", "SK") ' scary - the c is hard '
str_Word = Replace$(str_Word, "DGE", "J") ' edge '
str_Word = Replace$(str_Word, "DGY", "JE") ' edgy '
str_Word = Replace$(str_Word, "DGI", "JI") ' edginess '
str_Word = Replace$(str_Word, "TIA", "SHA")
str_Word = Replace$(str_Word, "TIO", "SHO")
str_Word = Replace$(str_Word, "TCH", "CH")
If Right$(str_Word, 2) = "GN" Then str_Word = Left$(str_Word, Len(str_Word) - 2) & "N" ' sign '
If Right$(str_Word, 4) = "GNED" Then str_Word = Left$(str_Word, Len(str_Word) - 4) & "ND"
If Right$(str_Word, 5) = "GNING" Then str_Word = Left$(str_Word, Len(str_Word) - 5) & "NING"
If Right$(str_Word, 2) = "IC" Then str_Word = Left$(str_Word, Len(str_Word) - 2) & "IK" ' rustic, fantastic '
i = InStr(str_Word, "W")
Do While i > 0
If InStr("AEIOU", Mid$(str_Word & " ", i + 1, 1)) = 0 Then
' W not followed by a vowel is silent. '
If i > 1 Then
str_Word = RTrim$(Left$(str_Word, i - 1) & _
Mid$(str_Word & " ", i + 1))
Else
str_Word = Mid$(str_Word, 2)
End If
End If
i = InStr(i + 1, str_Word, "W")
Loop
' Metaphone says that G is silent in GH, '
' but the GH becomes F in LAUGHTER. '
' Change letters to codes, '
' starting with 2nd letter: '
For i = 2 To Len(str_Word)
d = Mid$(str_Word, i, 1)
If InStr("AEIOUHWY", d) > 0 Then
d = "0" ' zero, not uppercase "o". '
ElseIf InStr("BFPV", d) > 0 Then
d = "1"
ElseIf InStr("GJKQ", d) > 0 Then
d = "2"
ElseIf InStr("CSXZ", d) > 0 Then
' Split these from last line because '
' GJKQ are hard sounds and CSXZ are '
' sibilants ("s" sounding), other '
' that the adjustments to C combos '
' made above. '
d = "7"
ElseIf InStr("DT", d) > 0 Then
d = "3"
ElseIf InStr("L", d) > 0 Then
d = "4"
ElseIf InStr("MN", d) > 0 Then
d = "5"
ElseIf InStr("R", d) > 0 Then
d = "6"
Else
If d <> "-" Then Stop
d = ""
End If
Mid(str_Word, i, 1) = d
Next
wrd = ""
' Remove repeating codes: 50773 -> 5073 '
For i = 1 To Len(str_Word)
If Mid(str_Word, i, 1) <> _
Mid(str_Word & " ", i + 1, 1) _
Then
wrd = wrd + Mid(str_Word, i, 1)
End If
Next
If str_Word = "" Then Exit Function
' Get rid of vowels (which have been replaced by 0's): '
str_Word = Replace(wrd, "0", "")
str_Word = Left$(str_Word & "0000", 4)
Soundex = str_Word
End Function
