Soundex with Optional Accuracy (Revised)

Category:

Miscellaneous

Type:

Snippets

Difficulty:

Intermediate

Author:

Brian Gillham

Version Compatibility: Visual Basic 6

More information:

This soundex routine will return a value that is very handy when the spelling of a string is not exactly known -- the same value as the Oracle Soundex() function.

This revised (11/7/02) function is lot quicker and more efficient than the previous techniques that I have used.

For more information about the Soundex indexing system, see http://www.outfitters.com/genealogy/what-soundex.html

Instructions: Copy the declarations and code below and paste directly into your VB project.

Declarations:
' (None)

Code:

Private Function SoundEx(ByVal WordString As String, _
    Optional SoundExLen As Integer = 4) As String

Dim Counter As Integer
Dim CurrChar As String

If SoundExLen > 10 Then
    SoundExLen = 10
ElseIf SoundExLen < 4 Then
    SoundExLen = 4
End If
SoundExLen = SoundExLen - 1

WordString = UCase(WordString)

For Counter = 1 To Len(WordString)
    If Asc(Mid(WordString, Counter, 1)) < 65 Or _
          Asc(Mid(WordString, Counter, 1)) > 90 Then
       Mid(WordString, Counter, 1) = " "
    End If
Next Counter
WordString = Trim(WordString)

If Len(Trim(WordString)) = 0 Then
    SoundEx = ""
Else
    SoundEx = WordString
    
    SoundEx = Replace(SoundEx, "A", "0")
    SoundEx = Replace(SoundEx, "E", "0")
    SoundEx = Replace(SoundEx, "I", "0")
    SoundEx = Replace(SoundEx, "O", "0")
    SoundEx = Replace(SoundEx, "U", "0")
    SoundEx = Replace(SoundEx, "Y", "0")
    SoundEx = Replace(SoundEx, "H", "0")
    SoundEx = Replace(SoundEx, "W", "0")
    SoundEx = Replace(SoundEx, "B", "1")
    SoundEx = Replace(SoundEx, "P", "1")
    SoundEx = Replace(SoundEx, "F", "1")
    SoundEx = Replace(SoundEx, "V", "1")
    SoundEx = Replace(SoundEx, "C", "2")
    SoundEx = Replace(SoundEx, "S", "2")
    SoundEx = Replace(SoundEx, "G", "2")
    SoundEx = Replace(SoundEx, "J", "2")
    SoundEx = Replace(SoundEx, "K", "2")
    SoundEx = Replace(SoundEx, "Q", "2")
    SoundEx = Replace(SoundEx, "X", "2")
    SoundEx = Replace(SoundEx, "Z", "2")
    SoundEx = Replace(SoundEx, "D", "3")
    SoundEx = Replace(SoundEx, "T", "3")
    SoundEx = Replace(SoundEx, "L", "4")
    SoundEx = Replace(SoundEx, "M", "5")
    SoundEx = Replace(SoundEx, "N", "5")
    SoundEx = Replace(SoundEx, "R", "6")
    
    CurrChar = Left(SoundEx, 1)
    For Counter = 2 To Len(SoundEx)
        If Mid(SoundEx, Counter, 1) = CurrChar Then
            Mid(SoundEx, Counter, 1) = " "
        Else
            CurrChar = Mid(SoundEx, Counter, 1)
        End If
    Next Counter
    SoundEx = Replace(SoundEx, " ", "")
    
    SoundEx = Mid(SoundEx, 2)
    SoundEx = Replace(SoundEx, "0", "")
    
    SoundEx = SoundEx & String(SoundExLen, "0")
    SoundEx = Left(WordString, 1) & Left(SoundEx, SoundExLen)
End If
End Function