'
'  pb_sndx.bas
'
'  Soundex routine for PB
'
'  By Don Dickinson
'  ddickinson@usinternet.com
'  dickinson.basicguru.com
'
'  Hereby Public Domain
'  Happily submitted to the public domain by the author; use at your own risk.
'
'  Based on a news group thread discussing soundex. Original author unknown.
'  Thanks to Errol Cheverie for sending the thread to me.
'

#if not %def(%PB_SNDX_BAS)

%PB_SNDX_BAS = 1

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'  SoundEx
'  Returns the 4 byte soundex string for the passed string.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function SoundEx Alias "SoundEx" _
   ( ByVal incoming as String ) Export as String

   Dim i as Long
   Dim sResult as String
   Dim sChar as String
   Dim lastChar as String
   
   '- Clean up the string
   '
   '  1.  Remove all non-alphabetic characters (e.g., commas, spaces).
   '  2.  Convert all lower-case characters to upper-case characters.
   '  3.  Move the first letter in the source to the SOUNDEX output buffer.
   '  4.  Remove the vowels (A, E, I, O, U and Y) and the consonents H and W.
   '  5.  Make the following substitutions:
   '        Labials (B,F,P,V)                      ==> 1
   '        Gutterals, sibilants (C,G,J,K,Q,S,X,Z) ==> 2
   '        Dentals (D,T)                          ==> 3
   '        Long liquid (L)                        ==> 4
   '        Nasals (M,N)                           ==> 5
   '        Short liquid (R)                       ==> 6
   '  6.  Combine any adjacent identical digits (i.e., eliminate contiguous
   '      matching digits: for example, 44 becomes just 4).
   '
   incoming = ucase$(incoming)
   sResult = ""
   For i = 1 to len(incoming)
      
      '- Stop when we get 4 characters
      if len(sResult) >= 4 then exit for
      
      sChar = mid$(incoming, i, 1) 
      
      '- Only A-Z are counted
      if (sChar <= "Z") and (sChar >= "A") then
         
         if sResult = "" then
            sResult = sChar
         else 

            '- No vowels allowed
            If instr("AEIOUYHW", sChar) < 1 then
               
               '- What digit corresponds to this letter
               if instr("BFPV", sChar) > 0 then
                  sChar = "1"
               elseif instr("CGJKQSXZ", sChar) > 0 then
                  sChar = "2"
               elseif instr("DT", sChar) > 0 then
                  sChar = "3"
               elseif sChar = "L" then
                  sChar = "4"
               elseif instr("MN", sChar) > 0 then
                  sChar = "5"
               elseif sChar = "R" then
                  sChar = "6"
               
               '- The "else" shouldn't happen
               else
                  sChar = ""
                  
               end if
               
               '- If it's the first digit, then just add it.
               if len(sResult) < 2 then
                  sResult = sResult + sChar
               
               '- Make sure not to add a repeating digit.
               elseif right$(sResult, 1) <> sChar then
                  sResult = sResult + sChar
               end if
            end if
         end if
      end if
   Next i 

   '  7.  Concatenate the first three resulting digits to the SOUNDEX output
   '      buffer (if there are fewer than 3 resulting digits, pad with 0).
   '
   Function = Left$(sResult + "0000", 4)  
   
End Function
#endif