Description
Returns a Soundex key for the supplied string

Comments
Returns a Soundex key for the supplied string.

The SOUNDEX algorithm generates a four-character key that describes the phonetic makeup of a word. The first character of this code is the first letter of the word. The remaining three characters are single digits that denote the phonetic value of the first three syllables of the word.

For example, a Soundex key of "A345" means:

"A" is the first letter of the word.
"3" is the phonetic value of the first syllable.
"4" is the phonetic value of the second syllable.
"5" is the phonetic value of the third syllable.

Returns
keyed string


Example
Sub Soundex ()
' ==============================================
' Example code for SoundexCode()
' ----------------------------------------------
' Displays the Soundex keys for a phrase and
' checks to see if they match.
' ==============================================
Dim strKey As String
Dim strKey2 As String

' Return the Soundex key for "Microsoft Access"
strKey = SoundexCode("Microsoft Access")
Debug.Print "The key for 'Microsoft Access' is: " & strKey

' Return the Soundex key for "Mykrosoft Axes"
strKey2 = SoundexCode("Mykrosoft Axes")
Debug.Print "The key for 'Mykrosoft Axes' is: " & strKey2

If strKey = strKey2 Then
Debug.Print "They Match!"
End If

End Sub

Function SoundexCode(strIn As String) As String
' Comments : returns a Soundex key for the supplied string
' Parameters: strIn - string to key
' Returns : keyed string
'
Dim intLen As Integer
Dim intChrCount As Integer
Dim intSDXCount As Integer
Dim intSep As Integer
Dim intSDXCode As Integer
Dim intPrvCode As Integer
Dim chrTmp As String * 1
Dim strSDX As String
Dim strTemp As String

intLen = Len(strIn)

Do Until (intSDXCount = 4 Or intChrCount = intLen)

intChrCount = intChrCount + 1

chrTmp = Mid(strIn, intChrCount, 1)

Select Case chrTmp
Case "B", "F", "P", "V": intSDXCode = 1
Case "C", "G", "J", "K", "Q", "S", "X", "Z": intSDXCode = 2
Case "D", "T": intSDXCode = 3
Case "L": intSDXCode = 4
Case "M", "N": intSDXCode = 5
Case "R": intSDXCode = 6
Case "A", "E", "I", "O", "U", "Y": intSDXCode = -1
Case Else: intSDXCode = -2
End Select

If intChrCount = 1 Then

' Handle the first character
strSDX = UCase(chrTmp)
intSDXCount = intSDXCount + 1
intPrvCode = intSDXCode
intSep = 0

Else

' Handle all other characters
If intSDXCode > 0 And (intSDXCode <> intPrvCode Or intSep = 1) Then
strSDX = strSDX + Format(intSDXCode, "#")
intSDXCount = intSDXCount + 1
intPrvCode = intSDXCode
intSep = 0
ElseIf intSDXCode = -1 Then
intSep = 1
End If
End If

Loop

If intSDXCount < 4 Then
strTemp = String((4 - intSDXCount), "0")
strSDX = strSDX & strTemp
End If

SoundexCode = strSDX

End Function