Возникла необходимость подготовить для Сбербанка список сотрудников нашей компании с указанием написания их фамилий в транслитерации по правилам Сбербанка. Возможно, данный код будет кому-то ещё полезен.
function BankCardTranslit(sFam, sName: string): string; var aChar:array [char] of string; stFamE, stNameE: string; function GetChar(c: char): string; begin Result := ''; if (c = 'Ь') or (c = 'Ъ') then Exit; Result := c; if not (c in ['A'..'Z', '0'..'9']) then Result := aChar[c]; end; function ToEnglish(ast: string): string; var i: integer; st: string; begin i := 1; Result := ''; while i <= Length(ast) do begin if i < Length(ast) then begin st := ast[i] + ast[i+1]; if (st = 'КС') then begin Result := Result+'X'; i := i + 2; Continue; end; if (st = 'ЬЯ') or (st = 'ИЯ') then begin Result := Result + 'IA'; i := i + 2; Continue; end; if (st = 'ИЙ') then begin Result := Result + 'Y'; i := i + 2; Continue; end; if (st = 'ЫЙ') then begin Result := Result + 'YY'; i := i + 2; Continue; end; end; Result := Result + GetChar(ast[i]); Inc(i); end; end; begin sFam := Trim(AnsiUpperCase(sFam)); sName := Trim(AnsiUpperCase(sName)); aChar['А'] := 'A'; aChar['Б'] := 'B'; aChar['В'] := 'V'; aChar['Г'] := 'G'; aChar['Д'] := 'D'; aChar['Е'] := 'E'; aChar['Ё'] := 'E'; aChar['Ж'] := 'ZH'; aChar['З'] := 'Z'; aChar['И'] := 'I'; aChar['Й'] := 'Y'; aChar['К'] := 'K'; aChar['Л'] := 'L'; aChar['М'] := 'M'; aChar['Н'] := 'N'; aChar['О'] := 'O'; aChar['П'] := 'P'; aChar['Р'] := 'R'; aChar['С'] := 'S'; aChar['Т'] := 'T'; aChar['У'] := 'U'; aChar['Ф'] := 'F'; aChar['Х'] := 'KH'; aChar['Ц'] := 'TS'; aChar['Ч'] := 'CH'; aChar['Ш'] := 'SH'; aChar['Щ'] := 'SHCH'; aChar['Ъ'] := ''; aChar['Ы'] := 'Y'; aChar['Ь'] := ''; aChar['Э'] := 'E'; aChar['Ю'] := 'YU'; aChar['Я'] := 'YA'; // поиск имен if sName = 'АЛЕКСАНДР' then stNameE := 'ALEXANDER'; if sName = 'ВЯЧЕСЛАВ' then stNameE := 'VJATCHESLAV'; if sName = 'ВИКТОР' then stNameE := 'VICTOR'; if sName = 'КУЗЬМА' then stNameE := 'KOUZMA'; if sName = 'ЛЮБОВЬ' then stNameE := 'LIUBOV'; if sName = 'ЛЮДМИЛА' then stNameE := 'LIUDMILA'; if sName = 'НАДЕЖДА' then stNameE := 'NADEZDA'; if sName = 'ФИЛИПП' then stNameE := 'PHILIPP'; if sName = 'ЮЛИЯ' then stNameE := 'JULIA'; if sName = 'ЮРИЙ' then stNameE := 'YURI'; if sName = 'ЯКОВ' then stNameE := 'IAKOV'; stFamE := ToEnglish(sFam); if (stNameE = '') then stNameE := ToEnglish(sName); // Проверка допустимой длины: если фамилия длинная, то берем только первую букву имени if (Length(stFamE) + Length(stNameE) + 1) > 19 then stNameE := GetChar(sName[1]); Result := stFamE + ' ' + stNameE; end;