Библиотека основанная на metaphone и объединяющая сразу несколько языков.

function MetaPhoneRu(w: string): string;
 //Второй вариант — пожалуй, лучший.
 //Заменяет ЙО, ЙЕ и др.; неплохо оптимизирован.
const
 alf = 'ОЕАИУЭЮЯПСТРКЛМНБВГДЖЗЙФХЦЧШЩЁЫ';
 cns1 = 'БЗДВГ';
 cns2 = 'ПСТФК';
 cns3 = 'ПСТКБВГДЖЗФХЦЧШЩ';
 ch = 'ОЮЕЭЯЁЫ';
 ct = 'АУИИАИА';
var
 i, b: integer;
 S, V, c, old_c, SelStr, Temp: string;
begin
 //Переводим в верхний регистр, оставляем только
 //символы из alf и копируем в S:
 W := AnsiUpperCase(W);
 Temp := CopyFromSymb(w, ' ');
 w := Copy2Space({Transliterator.Eng2Rus(w)}w);
 for i := 1 to Length(W) do
 begin
  c := Copy(W, i, 1);
  if Pos(c, alf) > 0 then
   S := S + c;
 end;
 if Length(S) = 0 then
  Exit;
 //Сжимаем окончания:
 SelStr := StrRight(S, 6);
 if SelStr = 'ОВСКИЙ' then
  S := StrLeft(S, Length(S) - 6) + '@'
 else if SelStr = 'ЕВСКИЙ' then
  S := StrLeft(S, Length(S) - 6) + '#'
 else if SelStr = 'ОВСКАЯ' then
  S := StrLeft(S, Length(S) - 6) + '$'
 else if SelStr = 'ЕВСКАЯ' then
  S := StrLeft(S, Length(S) - 6) + '%'
 else if (StrRight(S, 4) = 'ИЕВА') or (StrRight(S, 4) = 'ЕЕВА') then
  S := StrLeft(S, Length(S) - 4) + '9'
 else
 begin
  SelStr := StrRight(S, 3);
  if (SelStr = 'ОВА') or (SelStr = 'ЕВА') then
   S := StrLeft(S, Length(S) - 3) + '9'
  else if SelStr = 'ИНА' then
   S := StrLeft(S, Length(S) - 3) + '1'
  else if (SelStr = 'ИЕВ') or (SelStr = 'ЕЕВ') then
   S := StrLeft(S, Length(S) - 3) + '4'
  else if SelStr = 'НКО' then
   S := StrLeft(S, Length(S) - 3) + '3'
  else
  begin
   SelStr := StrRight(S, 2);
   if (SelStr = 'ОВ') or (SelStr = 'ЕВ') then
    S := StrLeft(S, Length(S) - 2) + '4'
   else if (SelStr = 'АЯ') then
    S := StrLeft(S, Length(S) - 2) + '6'
   else if (SelStr = 'ИЙ') or (SelStr = 'ЫЙ') then
    S := StrLeft(S, Length(S) - 2) + '7'
   else if (SelStr = 'ЫХ') or (SelStr = 'ИХ') then
    S := StrLeft(S, Length(S) - 2) + '5'
   else if SelStr = 'ИН' then
    S := StrLeft(S, Length(S) - 2) + '8'
   else if (SelStr = 'ИК') or (SelStr = 'ЕК') then
    s := StrLeft(S, Length(S) - 2) + '2'
   else if (SelStr = 'УК') or (SelStr = 'ЮК') then
    s := StrLeft(S, Length(S) - 2) + '0';
  end;
 end;

 //Оглушаем последний символ, если он - звонкий согласный:

 B := Pos(StrRight(S, 1), cns1);
 if B > 0 then
  S[Length(S)] := Copy(cns2, B, 1)[1];
 old_c := ' ';

 //Основной цикл:

 for i := 1 to Length(S) do
 begin
  c := Copy(S, i, 1);
  B := Pos(c, ch);
  if B > 0 then //Если гласная
   if (old_c = 'Й') or (old_c = 'И') then
    if (c = 'О') or (c = 'Е') then //Буквосочетания с гласной
    begin
     old_c := 'И';
     V[Length(V)] := old_c[1];
    end
    else if c <> old_c then //Если не буквосочетания с гласной, а просто гласная
     V := V + Copy(ct, B, 1)
    else
   else if c <> old_c then //Если не буквосочетания с гласной, а просто гласная
    V := V + Copy(ct, B, 1)
   else
  else //Если согласная
  begin
   if c <> old_c then //для «Аввакумов»
    if Pos(c, cns3) > 0 then //Оглушение согласных
    begin
     B := Pos(old_c, cns1);
     if B > 0 then
     begin
      old_c := Copy(cns2, B, 1);
      V[Length(V)] := old_c[1];
     end;
    end;
   if c <> old_c then
    V := V + c; //для «Шмидт»
  end;
  old_c := c;
 end;
 Result := Transliterator.Rus2Eng(V) + IfThen(V <> '', ' ' + Transliterator.Rus2Eng(Temp));
end;