Attribute VB_Name = "Soundex"
Option Compare Database
Option Explicit

Function SoundexCode()

'-------------------------------------------------------------
' Purpose : To produce the Soundex code
    '
' Notes :
'-------------------------------------------------------------

'Get the data
Dim strName As String
strName = InputBox("Enter Name", "SOUNDEX")

'Declare the 4 digits in the Soundex
Dim strFirst As String
Dim strSecond As String
Dim strThird As String
Dim strFourth As String

'The first letter remains the same
strFirst = Left(strName, 1)

'Get rid of a,e,i,o,u,y,h,w
strName = Replace(strName, "a", "")
strName = Replace(strName, "e", "")
strName = Replace(strName, "i", "")
strName = Replace(strName, "o", "")
strName = Replace(strName, "u", "")
strName = Replace(strName, "y", "")
strName = Replace(strName, "h", "")
strName = Replace(strName, "w", "")
strName = Replace(strName, "'", "")

'concatenate with the Name
Select Case strFirst
    Case "a"
    strName = strFirst & strName
    Case "e"
    strName = strFirst & strName
    Case "i"
    strName = strFirst & strName
    Case "o"
    strName = strFirst & strName
    Case "u"
    strName = strFirst & strName
    Case "y"
    strName = strFirst & strName
    Case "h"
    strName = strFirst & strName
    Case "w"
    strName = strFirst & strName
End Select


'Add the numeric code
strName = Replace(strName, "b", "1")
strName = Replace(strName, "p", "1")
strName = Replace(strName, "f", "1")
strName = Replace(strName, "v", "1")

strName = Replace(strName, "c", "2")
strName = Replace(strName, "s", "2")
strName = Replace(strName, "g", "2")
strName = Replace(strName, "j", "2")
strName = Replace(strName, "k", "2")
strName = Replace(strName, "q", "2")
strName = Replace(strName, "x", "2")
strName = Replace(strName, "z", "2")

strName = Replace(strName, "d", "3")
strName = Replace(strName, "t", "3")

strName = Replace(strName, "l", "4")

strName = Replace(strName, "m", "5")
strName = Replace(strName, "n", "5")

strName = Replace(strName, "r", "6")

'Need to get rid of doubles
'Doubles after the 4th place are irrelivent
If Mid(strName, 2, 1) = Mid(strName, 3, 1) Then
     strName = Left(strName, 1) & Mid(strName, 3, Len(strName))
End If
 
 If Mid(strName, 3, 1) = Mid(strName, 4, 1) Then
       strName = Left(strName, 2) & Mid(strName, 4, Len(strName))
End If
    
'Set the value of the next 3 digits
strSecond = Mid(strName, 2, 1)

strThird = Mid(strName, 3, 1)

strFourth = Mid(strName, 4, 1)

'Combine them together
Dim strCode As String
strCode = strFirst & strSecond & strThird & strFourth

'If there are less than 4 add zero's to the end
Select Case Len(strCode)
    Case 1
       strCode = strCode & "000"
    Case 2
        strCode = strCode & "00"
    Case 3
        strCode = strCode & "0"
End Select

'Combine the final Soundex code
MsgBox strCode

End Function