Function
Soundex(OriginalWord: string): string;
var
Tempstring1, Tempstring2: string;
Count: integer;
begin
Tempstring1 := '';
Tempstring2 := '';
OriginalWord := Uppercase(OriginalWord); {Переводим исходное слово в верхний регистр}
Appendstr(Tempstring1, OriginalWord[1]);
{Используем первую букву слова}
for Count := 2 to
length(OriginalWord) do
{Назначаем числовое значение каждой букве, за
исключением первой}
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');
{Все другие буквы, цифры и знаки пунктуации
игнорируются}
end;
Appendstr(Tempstring2, OriginalWord[1]);
{Удаляем из результата все последовательно
повторяющиеся цифры.}
for Count:=2 to
length(Tempstring1) do
if Tempstring1[Count-1]<>Tempstring1[Count] then
Appendstr(Tempstring2,Tempstring1[Count]);
Soundex:=Tempstring2; {Это - значение
soundex}
end;