Fórum Será possível????? #141720

unit TSoundex;

interface
uses Sysutils;
Function Soundex(OriginalWord:string):string;
Function Soundalike(Word1,Word2:string):boolean;


implementation
{Soundex function--determines whether two words sound alike.
 Written after reading an article in PC Magazine about the Soundex
 algorithm.  Pass the function a string.  It returns a Soundex value
 string.  This value can be saved in a database, or compared to another
 Soundex value.  If two words have the same Soundex value, then they sound
 alike (usually!).

 Note that the Soundex algorithm ignores the first letter of a word.  Thus,
 "won" and "one" will have different Soundex values, but "Won" and "Wunn"
 will have the same values.

 Soundex is especially useful in databases when one does not know how to
 spell a last name}
Function Soundex(OriginalWord:string):string;
var
  Tempstring1,Tempstring2:string;
  Count:integer;
begin
  Tempstring1:=´´;
  Tempstring2:=´´;
  OriginalWord:=Uppercase(OriginalWord); {Make original word uppercase}
  Appendstr(Tempstring1,OriginalWord[1]); {Use the first letter of the word}
  for Count:=2 to length(OriginalWord) do
      {Assign a numeric value to each letter, except the first}
      case OriginalWord[Count] of
        ´B´,´F´,´P´,´V´:
          Appendstr(Tempstring1,´1´);
        ´C´,´G´,´J´,´K´,´Q´,´S´,´X´,´Z´:
          Appendstr(Tempstring1,´2´);
        ´D´,´T´:
          Appendstr(Tempstring1,´3´);
        ´L´:
          Appendstr(Tempstring1,´4´);
        ´M´,´N´:
          Appendstr(Tempstring1,´5´);
        ´R´:
          Appendstr(Tempstring1,´6´);
        {All other letters, punctuation and numbers are ignored}
      end;

  Appendstr(Tempstring2,OriginalWord[1]);

  {Go through the result, and remove any consecutive numberic values
   that are duplicates}
  for Count:=2 to length(Tempstring1) do
    if Tempstring1[Count-1]<>Tempstring1[Count] then
        Appendstr(Tempstring2,Tempstring1[Count]);

  {Maximum Soundex Length is 4, pad if less, then truncate}
  Appendstr(Tempstring2,´000´);
  Delete(Tempstring2,5,20);

  Soundex:=Tempstring2; {This is the soundex value}

end;

{Soundalike--pass two strings to this function.  It returns True if they
 sound alike, False if they don´t.  Simply calls the Soundex function.}
Function Soundalike(Word1,Word2:string):boolean;
begin
  if (Soundex(Word1)=Soundex(Word2)) then
    result:=True
  else
    result:=False
end;

end.