Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Soundex

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Soundex

    Code:
    '
    '  pb_sndx.bas
    '
    '  Soundex routine for PB
    '
    '  By Don Dickinson
    '  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. 
    '  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
       
       '- 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
    ------------------
    dickinson.basicguru.com
    Don Dickinson
    www.greatwebdivide.com

  • #2
    Another Way
    Code:
    FUNCTION SoundEx ALIAS "SoundEx" _
       ( BYVAL incoming AS STRING ) EXPORT AS STRING
       DIM i AS LONG, x AS LONG
       DIM sResult AS STRING
       DIM sChar AS STRING
       DIM sx AS STRING * 26
       sx$ = "01230120022455012623010202"
       incoming = UCASE$(incoming)
       i&=1:x&=LEN(incoming)
       DO WHILE i& <= x& AND LEN(sResult) < 4  ' will exit on null and length 4
        sChar = MID$(incoming,i&,1)
        IF sChar =>"A" AND sChar =<"Z" THEN
          IF sResult = "" THEN
             sResult = sChar
          ELSE
             sChar=MID$(sx$,ASC(sChar)-64,1)
             IF sChar > "0" THEN
               IF LEN(sResult) < 2 THEN
                  sResult=sResult+sChar
               ELSEIF RIGHT$(sResult, 1) <> sChar THEN
                      sResult = sResult + sChar
               END IF
             END IF
          END IF
        END IF
        INCR i&
       LOOP
       FUNCTION = LEFT$(sResult + "0000", 4)
    
    END FUNCTION
    ------------------
    E-Mail: thedoggizmo@home.com
    E-Mail:
    pt AT pursuersoft DOT com

    Comment

    Working...
    X