[AccessD] Re: Soundex Function

List,

Here are the functions required:

Function Soundex(ByVal strIn As String) As String
     ' Create a Soundex lookup string for the
     ' input text.
     ' Parameters:
     '   strIn:
     '       The text to encode
     ' Returns:
     '   Return value:
     '       strIn, converted to Soundex format.
     ' Other Functions Required:
     '   IsCharAlpha
     '   PadRight
     Dim strOut As String
     Dim intI As Integer
     Dim intPrev As Integer
     Dim strChar As String * 1
     Dim intChar As Integer
     Dim fPrevSeparator As Boolean
     strOut = ""
     strIn = UCase(strIn)
     fPrevSeparator = True
     strOut = Left$(strIn, 1)
     For intI = 2 To Len(strIn)
         ' If the output string is full, quit now.
         If Len(strOut) >= intLen Then
             Exit For
         End If
         ' Get each character, in turn. If the
         ' character's a letter, handle it.
         strChar = Mid$(strIn, intI, 1)
         If IsCharAlpha(strChar) Then
             ' Convert the character to its code.
             intChar = CharCode(strChar)
             ' If the character's not empty, and if it's not
             ' the same as the previous character, tack it
             ' onto the end of the string.
             If (intChar > 0) Then
                 If fPrevSeparator Or (intChar <> intPrev) Then
                     strOut = strOut & intChar
                     intPrev = intChar
                 End If
             End If
             fPrevSeparator = (intChar = 0)
         End If
     Next intI
     ' Return the string, right padded with 0's.
     Soundex = PadRight(strOut, intLen, "0")
End Function

Private Function CharCode(strChar As String) As Integer
     Select Case strChar
         Case "A", "E", "I", "O", "U", "Y"
             CharCode = 0
         Case "C", "G", "J", "K", "Q", "S", "X", "Z"
             CharCode = 2
         Case "D", "T"
             CharCode = 3
         Case "M", "N"
             CharCode = 5
         Case "B", "F", "P", "V"
             CharCode = 1
         Case "L"
             CharCode = 4
         Case "R"
             CharCode = 6
         Case Else
             CharCode = -1
     End Select
End Function

Function IsCharAlpha(strText As String) As Boolean
     ' Is the first character of strText an alphabetic character?
     ' Parameters:
     '   strText:
     '       Text to check. Only first character will be examined.
     ' Returns:
     '   Return Value:
     '       True if first character of strText is alphabetic in
     '       the current locale.
     ' Example:
     '   If IsCharAlpha(strSomeValue) Then
     '       ' you know the first character is alphabetic.
     '   End If
     ' Other Functions Required:
     '   IsCharsetWide
     ' Other Functions Using This One:
     '   Soundex
     '   IsCharNumeric

     If IsCharsetWide() Then
         IsCharAlpha = CBool(IsCharAlphaW(AscW(strText)))
     Else
         IsCharAlpha = CBool(IsCharAlphaA(Asc(strText)))
     End If
End Function

Function SoundsLike(ByVal strItem1 As String, ByVal strItem2 As String, _
         Optional fIsSoundex As Boolean = False) As Integer
     ' Return a number between 0 and 4 (4 being the best) indicating
     ' the similarity between the Soundex representation for
     ' two strings.
     ' Other Functions Required:
     '   Soundex
     ' Parameters:
     '   strItem1 , strItem2:
     '       Strings to compare
     '   fIsSoundex (Optional, default False):
     '       Are the strings already in Soundex format?
     ' Returns:
     '   Return Value:
     '       Integer between 0 (not similar) and intLen (very similar) 
indicating
     '       the similarity in the Soundex representation of the two strings.
     ' Note:
     '   This code is extremely low-tech. Don't laugh! It just compares
     '   the two Soundex strings until it doesn't find a match, and returns
     '   the position where the two diverged.
     '   Remember, two Soundex strings are completely different if the
     '   original words start with different characters. That is, this
     '   function always returns 0 unless the two words begin with the
     '   same character.
     Dim intI As Integer
     If Not fIsSoundex Then
         strItem1 = Soundex(strItem1)
         strItem2 = Soundex(strItem2)
     End If
     For intI = 1 To intLen
         If Mid$(strItem1, intI, 1) <> Mid$(strItem2, intI, 1) Then
             Exit For
         End If
     Next intI
     SoundsLike = (intI - 1)
End Function


At 08:45 AM 10/22/2003 -0500, you wrote:
>Date: Wed, 22 Oct 2003 05:24:18 -0400
>From: "Bryan Carbonnell" <carbonnb at sympatico.ca>
>Subject: RE: [AccessD] "fuzzy logic" search
>To: Access Developers discussion and problem solving
>         <accessd at databaseadvisors.com>
>Message-ID: <3F961482.29626.108D43 at localhost>
>Content-Type: text/plain; charset=US-ASCII
>
>On 21 Oct 2003 at 20:32, John Colby wrote:
>
> > Hmmm soundex would be good though.  Do you have this function?  Is it
> > a class, a single function?  How does it work?
>
>ADH has a Soundex Version. I don't recall if it's a single procedure
>or a series of procedures. I don't think it's a class though.
>
>--
>Bryan Carbonnell - carbonnb at sympatico.ca
>RAM Disk is not an installation technique!