Binaryworld - Soundex - Determine the phonetic code of a word ... [ VB -> String ]

' The Soundex code of an alphabetical string
'
' you can use Soundex code for phonetic searches
' Beware: this isn't bullet-proof!
'
' UPDATE: this version corrects a bug in the original routine
'     thanks to Edward Wittke for spotting the mistake

Function Soundex(ByVal word As String) As String
  Dim result As String
  Dim i As Long, acode As Integer
  Dim dcode As Integer, oldCode As Integer

  ' soundex is case-insensitive
  word = UCase$(word)
  ' the first letter is copied in the result
  Soundex = Left$(word, 1)
  oldCode = Asc(Mid$("01230120022455012623010202", Asc(word) - 64))

  For i = 2 To Len(word)
    acode = Asc(Mid$(word, i, 1)) - 64
    ' discard non-alphabetic chars
    If acode >= 1 And acode <= 26 Then
      ' convert to a digit
      dcode = Asc(Mid$("01230120022455012623010202", acode, 1))
      ' don't insert repeated digits
      If dcode <> 48 And dcode <> oldCode Then
        Soundex = Soundex & Chr$(dcode)
        If Len(Soundex) = 4 Then Exit For
      End If
      oldCode = dcode
    End If
  Next
End Function