The "Soundex" Function in Visual Basic

There are small differences in popular implementations of the Soundex function. I have written two VB versions of Soundex, that produce exactly the same results as Oracle and the Microsoft SQL Server.

For more information about the Soundex algorithm: NIST Dictionary of Algorithms and Data Structures

Download File: Soundex_VB6.zip
(The ZIP file includes a test program that uses random string values to compares the VB Soundex functions with the Soundex functions of Oracle and MS SQL Server)

Oracle-compatible Version

' Computes the "Soundex" value of a string.
' This version produces exactly the same results as the Soundex
' function of Oracle 8.
' Author: Christian d'Heureuse, chdh@source-code.biz
Public Function Soundex1(ByVal s As String)
   Const CodeTab = " 123 12  22455 12623 1 2 2"
   '                abcdefghijklnmopqrstuvwxyz
   Dim c As Integer
   Dim p As Integer: p = 1
   Do
      If p > Len(s) Then Soundex1 = Null: Exit Function
      c = Asc(Mid(s, p, 1))
      p = p + 1
      If c >= 65 And c <= 90 Then Exit Do
      If c >= 97 And c <= 122 Then c = c - 32: Exit Do
      Loop
   Dim ss As String, PrevCode As String
   ss = Chr(c)
   PrevCode = Mid$(CodeTab, c - 64, 1)
   Do While Len(ss) < 4 And p <= Len(s)
      c = Asc(Mid(s, p))
      If c >= 65 And c <= 90 Then
         ' nop
       ElseIf c >= 97 And c <= 122 Then
         c = c - 32
       Else
         c = 0
         End If
      Dim Code As String: Code = "?"
      If c <> 0 Then
         Code = Mid$(CodeTab, c - 64, 1)
         If Code <> " " And Code <> PrevCode Then ss = ss & Code
         End If
      PrevCode = Code
      p = p + 1
      Loop
   If Len(ss) < 4 Then ss = ss & String$(4 - Len(ss), "0")
   Soundex1 = ss
   End Function

MS-SQL-Server-compatible Version

' Computes the "Soundex" value of a string.
' This version produces exactly the same results as the Soundex
' function of Microsoft SQL Server 2000.
' Author: Christian d'Heureuse, chdh@source-code.biz
Public Function Soundex2(ByVal s As String) As String
   Const CodeTab = " 123 12  22455 12623 1 2 2"
   '                abcdefghijklnmopqrstuvwxyz
   If Len(s) = 0 Then Soundex2 = "0000": Exit Function
   Dim c As Integer
   c = Asc(Mid$(s, 1, 1))
   If c >= 65 And c <= 90 Or c >= 97 And c <= 122 Then
      ' nop
    ElseIf c >= 192 And c <= 214 Or c >= 216 And c <= 246 Or c >= 248 Then
      ' nop
    Else
      Soundex2 = "0000"
      Exit Function
      End If
   Dim ss As String, PrevCode As String
   ss = UCase(Chr(c))
   PrevCode = "?"
   Dim p As Integer: p = 2
   Do While Len(ss) < 4 And p <= Len(s)
      c = Asc(Mid(s, p))
      If c >= 65 And c <= 90 Then
         ' nop
       ElseIf c >= 97 And c <= 122 Then
         c = c - 32
       ElseIf c >= 192 And c <= 214 Or c >= 216 And c <= 246 Or c >= 248 Then
         c = 0
       Else
         Exit Do
         End If
      Dim Code As String: Code = "?"
      If c <> 0 Then
         Code = Mid$(CodeTab, c - 64, 1)
         If Code <> " " And Code <> PrevCode Then ss = ss & Code
         End If
      PrevCode = Code
      p = p + 1
      Loop
   If Len(ss) < 4 Then ss = ss & String$(4 - Len(ss), "0")
   Soundex2 = ss
   End Function

Author: Christian d'Heureuse (www.source-code.biz, www.inventec.ch/chdh)
License: Free / LGPL
Index