Транслитерация кириллицы в латиницу

Delphi FAQ >> Алгоритмы

function TranslitRus2Lat(const Str: String): String;
const
  RArrayL = 'абвгдеёжзийклмнопрстуфхцчшщьыъэюя';
  RArrayU = 'АБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЬЫЪЭЮЯ';
  colChar = 33;
  arr: array[1..2, 1..ColChar] of String =
(('a','b','v','g','d','e','yo','zh','z','i','y',
'k','l','m','n','o','p','r','s','t','u','f',
'kh','ts','ch','sh','shch','''','y','''','e','yu','ya'),
('A','B','V','G','D','E','Yo','Zh','Z','I','Y',
'K','L','M','N','O','P','R','S','T','U','F',
'Kh','Ts','Ch','Sh','Shch','''','Y','''','E','Yu','Ya'));
var
  i: Integer;
  LenS: Integer;
  p: Integer;
  d: Byte;
begin
  result := '';
  LenS := length(str);
  for i := 1 to lenS do
  begin
    d := 1;
    p := pos(str[i], RArrayL);
    if (p = 0) then
    begin
      p := pos(str[i], RArrayU);
      d := 2
    end;
    if (p<>0) then result := result + arr[d, p]
    //если не русская буква, то берем исходную
    else result := result + str[i];
  end;
end;