The "Soundex" Function in Visual Basic (VBasic / VB)

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