| Public Function Soundex(sWord As String) As String
Dim nPos As Long
Dim nSoundPos As Long
Dim bLastVowel As Boolean
Dim sLastCode As String
Dim sCode As String
If Len(sWord) = 0 Then
Soundex = "0000"
Exit Function
End If
Soundex = UCase(Mid(sWord, 1, 1)) & "000"
nSoundPos = 2
nPos = 2
bLastVowel = False
sLastCode = xSoundexGetCode(UCase(Mid(sWord, 1, 1)))
Do While nPos <= Len(sWord) And nSoundPos <= 4
If xSoundexIsVowel(Mid(sWord, nPos, 1)) Then
bLastVowel = True
Else
sCode = xSoundexGetCode(Mid(sWord, nPos, 1))
If bLastVowel Then
sLastCode = ""
End If
If sCode <> sLastCode Then
If Len(sCode) = 1 Then
sLastCode = sCode
Mid(Soundex, nSoundPos, 1) = sCode
nSoundPos = nSoundPos + 1
End If
End If
bLastVowel = False
End If
nPos = nPos + 1
Loop
End Function
Private Function xSoundexIsVowel(sLetter As String) As Boolean
Select Case UCase(sLetter)
Case "A", "E", "I", "O", "U", "Y"
xSoundexIsVowel = True
Case Else
xSoundexIsVowel = False
End Select
End Function
Private Function xSoundexGetCode(sLetter As String) As String
Select Case UCase(sLetter)
Case "B", "F", "P", "V"
xSoundexGetCode = "1"
Case "C", "G", "J", "K", "Q", "S", "X", "Z"
xSoundexGetCode = "2"
Case "D", "T"
xSoundexGetCode = "3"
Case "L"
xSoundexGetCode = "4"
Case "M", "N"
xSoundexGetCode = "5"
Case "R"
xSoundexGetCode = "6"
Case Else
xSoundexGetCode = ""
End Select
End Function
Private Function xSoundexTest()
Debug.Assert Soundex("Gutierrez") = "G362"
Debug.Assert Soundex("Pfister") = "P236"
Debug.Assert Soundex("Jackson") = "J250"
Debug.Assert Soundex("Tymczak") = "T522"
Debug.Assert Soundex("VanDeusen") = "V532"
Debug.Assert Soundex("Tymczak") = "T522"
Debug.Assert Soundex("Ashcraft") = "A261"
Debug.Assert Soundex("Washington") = "W252"
Debug.Assert Soundex("Lee") = "L000"
End Function
|