🚀 go-pugleaf

On Mon, 6 Jul 1998 22:39:52 +0100, "Miguel Angel Ferrer"
<mfc@redestb.es> wrote:

>    I need a SOUNDEX algorythm for any programming language.
>
>    Thanks
>
>    mfc@redestb.es
>
>
I use the routine below to store a Soundex string into
tables of Companies and contacts. In searches I look for
"@smith" entered to search crd_soundex instead of
crd_surname. 

Function Soundex (ByVal InName As String) As String
  ' soundex algorithm based upon an article in Practical
Computing February 1984 for the Commodore Pet
  ' As implemented in the sub-routine the steps in the
coding a name into its Soundex equivalents are as follows:-
  ' 1 The first letter of the code is the first letter of
the name
  ' 2 Subsequent letters of the name are replaced as
follows:
  '   B,F,P or V - replaced by P
  '   C, G, J, K, Q,S, X or Z - replaced by S
  '   M or N - replaced by N
  '   L or R - replaced by M
  '   A,E,I,O,U,W,H or Y - not coded
  '   All consontant with similat pronunciation are grouped
together
  ' 3 A sequence of uninterrrupted letters of the same codes
value
  '   is replaced by a single code letter, although this
does not
  '   include the first letter of the name. If can be
included by
  '   changing l$="" to l$=out_string.
  ' 4 The code is forced to be exactly four characters long,
either
  '   truncated or by padding at the right with the letter
A.
  '
  ' In the examples below phonetically similar names code
identically,
  ' though the quirks of English spelling and pronunciation
mean that
  ' this is not always the case. "Belvoir" codes to BLPR,
whereas it
  ' may be prounced "Beaver", which codes to BPRA. Similarly
"Bough"
  ' codes to BSAA but can be prounced "Boff" or "Bow", which
have
  ' Soundex codes of BPAA and BAAA respectively.
  '
  ' WATT, WITHE, WAITE, WHITE, WYATT code to WTAA
  ' GURNEY, GRIM, GOREN, GREEN code to GRMA
  '
  Dim in_string As String
  Dim out_string As String
  Dim i As Integer, n As Integer
  Dim l$, a$, c$

  l$ = ""
  n = 0
  
  ' convert to upper case

  in_string = UCase$(InName)
  out_string = Left$(in_string, 1)
  For i = 2 To Len(in_string)
    a$ = Mid(in_string, i, 1)
    ' finish at the first word break
    ' don't treat . as a word break - B.T. would then pick
up BT
    If InStr(" !"",;:@#/\|", a$) > 0 Then
      i = Len(in_string) + 1
    Else
      Select Case a$
      Case "B", "F", "P", "V"
        c$ = "P"
        GoSub subit
      Case "C", "G", "J", "K", "Q", "S", "X", "Z"
        c$ = "S"
        GoSub subit
      Case "T", "D"
        c$ = "T"
        GoSub subit
      Case "M", "N"
        c$ = "M"
        GoSub subit
      Case "L", "R"
        c$ = a$
        GoSub subit
      Case Else
        l$ = a$
      End Select
    End If
  Next
  If n < 3 Then
    out_string = out_string & Left$("AAA", 3 - n)
  Else
    out_string = Left$(out_string, 4)
  End If
  Soundex = out_string
Exit Function

subit:
  If c$ <> l$ Then
    out_string = out_string & c$
    n = n + 1
    l$ = c$
  End If
  Return

End Function