Funcao - soundex 2

// Usava esta rotina em um sistema em que a chave de procura era o sobrenome e a

// data de nascimento, posuíamos uma base de + de 250.000

// nomes. usava da seguinte maneira: ao incluir um nome, o sobrenome passava por

// esta rotina e o resultado era gravado em um campo chave

// da tabela, para fazer a consulta, o sobrenome digitado passava por esta rotina

// e o resultado era usado na pesquisa.

// vc pode digitar por exemplo:

// Nascimento, Nacimento, Nasimento, Naximento

// Marco, Marcus

// ximenes, chimenes, shimenes

// Jacques, Jaques

// O Retorno tem sempre tamanho 8

function Fonema(const Palavra: string): string;

var

  X     : Integer;

  R     : string[8];

  Valor : string[1];

  Nome  : string[20];

begin

  R := '';

  Nome := Copy(Trim(Palavra),1,8);

  if Length(Nome) > 1 then

  begin

    if Nome[Length(Nome)]                        = 'D'  then Delete(Nome,Length(Nome),1);

    if Nome[Length(Nome)]                        = 'T'  then Delete(Nome,Length(Nome),1);

    if Nome[Length(Nome)-1] + Nome[Length(Nome)] = 'TH' then Nome[Length(Nome)]       := 'E';

    if Nome[Length(Nome)-1] + Nome[Length(Nome)] = 'US' then Nome[Length(Nome)-1]     := 'O';

    if (Pos('NUE', Nome) <> 0)                          then Nome[Pos('NUE', Nome)+1] := 'O';

    if (Pos('D', Nome) <> 0) and (Pos('D', Nome) <> Length(Nome)) then

      if not (Nome[Pos('D',Nome)+1] in ['A','E','I','O','U','D',#39]) then

        Insert('I', Nome, Pos('D', Nome)+1);

    X := Pos('GN',Nome);

    if X <> 0 then

    begin

      Insert('U', Nome, X + 1);

      Insert('I', Nome, X + 2);

    end;

    for X := 1 to Length(Nome) do

    begin

      Nome[X] := upcase(Nome[X]);

      Valor := '';

      case Nome[X] of

        'S','C','X','Z','K','Q' : Valor := '1';

        'E','Y','I'             : Valor := '2';

        'L','U','W','V'         : Valor := '3';

        'J','G'                 : Valor := '4';

        'B','F'                 : Valor := '5';

        'M','N'                 : Valor := '6';

        'D','T','R'             : Valor := '7';

      end;

      if R[Length(R)] <> Valor then R := R + Valor;

    end;

    while Length(R) < 8 do R := R + #32;

  end;

  Result := R;

end;