Function Soundex (szSurname As String) As String

'Copyright 1992 Paul Litwin.
'ALL RIGHTS RESERVED.
'
'Permission is hereby granted to use and distribute this function
'as long as it is incorporated into databases and applications with
'added value.  You are forbidden from selling this function by itself.
'
'Persons finding utility in this function are encouraged to subscribe to
'Smart Access.  The author of this function is the editor of this monthly
'technical journal.  Contact Pinnacle Publishing for subscription info
'at 800-788-1900 or 206-251-1900.  An article discussing this function in
'detail and its use in Access applications is featured in the 
'February 1993 charter issue of Smart Access. 
' 
'Paul Litwin can be reached on CIS @ 76447,417 or at 206-223-3525.
'
'Soundex takes a surname string and returns a 4-digit string
'representing the Russell Soundex code.
'According to the 1967 paper in a American Journal of Human Genetics,
'the Russell algorithm is "...the method of choice for almost all
'populations, except where the names are predominantly of Oriental
'origin".  This commonly used algorithm is used for geneology and vital
'statistics tracking in the United States.
'The agorithm works as follows:
'1.  Use the first letter of the surname, as is.
'    This letter is termed the prefix character.
'2.  The remaining characters in the surname are coded with three
'    digits ranging from 0 to 6.
'    a.  Ignore W and H, spaces and any non-alphabetic characters.
'    b.  Vowels and Y are also ignored, but they do serve as
'        separators for repeating consonant sounds.
'    c.  The remaining consonants are given a code from 1 to 6.
'    d.  A repeat of a previously coded consonant is not coded,
'        unless a separator is present (e.g., for "MN", only the
'        M is coded, since M and N have the same code, but for
'        "MON", both M and N are coded).
'3.  Once the soundex code is 4-characters long (including the
'    prefix), stop.  If there are no additional characters in
'    the name, and less than four characters in the code have been
'    used, fill the remainder of the code with zeros.

Dim wLength, wCharCount, wSdxCount, wSeparator, wSdxCode, wPrvCode As Integer
Dim szCurrChar, szSdx As String

wLength = Len(szSurname)  'Get the length of the name

If wLength = 0 Then       'If a null string was passed, return a null
    Soundex = ""
    Exit Function
End If

wSeparator = 0            'Keeps track of vowel separators
wPrvCode = 0              'The code of the previous character
wSdxCount = 0             'A counter of the number of soundex characters
wCharCount = 0            'A counter of the number of surname characters

Do Until (wSdxCount = 4 Or wCharCount = wLength)
			  'loop until the soundex code is of length 4
			  'or we have run out of characters in the surname

wCharCount = wCharCount + 1
szCurrChar = Mid(szSurname, wCharCount, 1)

Select Case szCurrChar    'Calculate the code for the current character
    Case "B", "F", "P", "V"
	wSdxCode = 1
    Case "C", "G", "J", "K", "Q", "S", "X", "Z"
	wSdxCode = 2
    Case "D", "T"
	wSdxCode = 3
    Case "L"
	wSdxCode = 4
    Case "M", "N"
	wSdxCode = 5
    Case "R"
	wSdxCode = 6
    Case "A", "E", "I", "O", "U", "Y"
	wSdxCode = -1
    Case Else
	wSdxCode = -2
End Select

If wCharCount = 1 Then     'Treat the first character specially
    szSdx = UCase(szCurrChar)
    wSdxCount = wSdxCount + 1
    wPrvCode = wSdxCode
    wSeparator = 0
ElseIf wSdxCode > 0 And (wSdxCode <> wPrvCode Or wSeparator = 1) Then
			   'If a significant constant and not a repeat
			   'without a separator then code this character
    szSdx = szSdx + Format(wSdxCode, "#")
    wSdxCount = wSdxCount + 1
    wPrvCode = wSdxCode
    wSeparator = 0
ElseIf wSdxCode = -1 Then   'If a vowel, this character is not coded,
    wSeparator = 1          'but it will act as a separator
End If

Loop
    
If wSdxCount < 4 Then       'If the code is < 4 chars long, then
			    'fill the rest of code with zeros
    szSdx = szSdx + String((4 - wSdxCount), "0")
End If

Soundex = szSdx             'Return the soundex code

End Function

