SoundexConv

Option Explicit

Public Function ConvertToSoundex(ByVal strToConvert As String) _
As String
Dim strSoundexCode As String
Dim strCurrentCharacter As String
Dim strCurrentSoundex As String
Dim strPreviousCharacter As String
Dim intCharacterCount As Integer
'Convert the input string to all caps and strip all spaces

strToConvert = UCase$(Trim(strToConvert))
'The first Soundex digit is the first letter of the input string

strSoundexCode = Left(strToConvert, 1)
'start checking the input string with the second character

intCharacterCount = 2
Do While Not Len(strSoundexCode) = 4'Soundex code is only 4 digits
'get the charater to check

strCurrentCharacter = Mid$(strToConvert, intCharacterCount, 1)
'If the letter has no Soundex equivalentcontinue on

'otherwise get the previous letter and check to see if

'the current letter's Soundex code is the same as the

'previous letter's. If it is, continue without doing

'anything, otherwise concatenate the Soundex code to

'the rest of the Soundex string.

If InStr(1, "AEIOUYHW", strCurrentCharacter) = 0 Then
strPreviousCharacter = Mid$(strToConvert, _
intCharacterCount - 1, 1)
strCurrentSoundex = GetSoundex(strCurrentCharacter)
If strCurrentSoundex <> GetSoundex(strPreviousCharacter) _
Then strSoundexCode = strSoundexCode & _
strCurrentSoundex
End If
'If the current character is the last, exit the loop.

If intCharacterCount = Len(strToConvert) Then Exit Do
'Otherwise continue checking characters

intCharacterCount = intCharacterCount + 1
Loop
'If the Soundeex string is not 4 digits,pad the end with 0's

Do Until Len(strSoundexCode) = 4
strSoundexCode = strSoundexCode & "0"
Loop
'Return the Soundex code

ConvertToSoundex = strSoundexCode
End Function

Public Function GetSoundex(ByVal strLetter As String) As String
Select Case strLetter
Case "B", "P", "F", "V"
GetSoundex = "1"
Case "C", "S", "G", "J", "K", "Q", "X", "Z"
GetSoundex = "2"
Case "D", "T"
GetSoundex = "3"
Case "L"
GetSoundex = "4"
Case "M", "N"
GetSoundex = "5"
Case "R"
GetSoundex = "6"
Case Else
GetSoundex = vbNullString
End Select
End Function
Inputs:A string

Returns:4 digit Soundex code as a string

Assumes:
This code has two functions. The main function perfoms the
handles all the inputs, outputs, and string comparison and
concatenations. The subfunction is called from the main to
convert a letter into its Soundex equivalent.

Side Effects:
Prefixes to surnames such as van, Von, Di, de, le, D', dela,
or du are sometimes ignored. This code does not ignore them.