Автор: Евгений Меньшенин
WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Сумма прописью

Данный набор функций позволяет из суммы в числовом виде получить
её представление прописью. Реализована возможность работы с рублями и долларами.
Возможно добавление какой угодно валюты.

Зависимости: SysUtils
Автор:       fnatali, fnatali@yandex.ru, Березники
Copyright:   Евгений Меньшенин <johnmen@mail.ru>
Дата:        27 апреля 2002 г.
***************************************************** }

unit SpellingD;

interface

uses SysUtils;

function SpellPic(StDbl: double; StSet: integer): string;

implementation

const
  Money: array[0..1] of string[25] =
  ('ь я рубл ей коп. ',
    'р ра долларов цент.');
  {А Б В Г Д Е Ж З И Й К Л М Н О
        П Р С Т У Ф Х Ц Ч Ш Щ Ъ Ы Ь
        Э Ю Я а б в г д }
  Sym: string[180] =
  'одна две один два три четыре пят ь шест сем восемдевятдесят'
    + 'на дцатьсорокдевяно сто сти ста ьсот тысяча и миллион '
    + 'ов ард ноль ь я рубл ей коп. ';
  Code: string[156] =

  'БААВААГААДААЕААЖЗАИЙАКЙАЛЙАМЙАНЙАОЙАГПРВПРЕПРЖПРИПРКПРЛПРМПРНПРДРАЕРА'
    +
    'СААИЙОКЙОЛЙОМЙОТУФФААВХАЕЦАЖЗЦИЧАКЧАЛЧАМЧАНЧАваАвбАвгАШЩАШЪАШААЫЬАЫЬЩ'
    + 'ЫЬЭЫЮАЫЮЩЫЮЭЯААдАА';
  {1 2 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 30
   40 50 60 70 80 90 1 2 3 4 5 6 7 8 9 РУБ -Я-ЕЙТЫС -И -ЧМ-Н-А
    -ВМ-Д -А -В0 коп}
  {0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
   23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45
   46 47 48 49 50 51 }

function SpellPic(StDbl: double; StSet: integer): string;
{format of StNum: string[15]= 000000000000.00}
const
  StMask = '000000000000.00';
var
  StNum: string; {StDbl -> StNum}
  PlaceNo: integer; {текущая позиция в StNum}
  TripletNo: integer; {позиция имени обрабатываемого разряда (им.п.ед.ч.)}
  StWord: string; {результат}

  procedure WordAdd(CodeNo: integer);
  var
    SymNo: integer; {текущая позиция в массиве Sym}
    i, j: integer;
  begin
    ;
    Inc(CodeNo, CodeNo shl 1); {* 3}
    for i := 1 to 3 do
    begin
      ;
      Inc(CodeNo);
      SymNo := ord(Code[CodeNo]) - ord('Б');
      if SymNo < 0 then
        break;
      Inc(SymNo, SymNo shl 2); {* 5}
      for j := 1 to 5 do
      begin
        ;
        Inc(SymNo);
        if Sym[SymNo] = ' ' then
          break;
        StWord := StWord + Sym[SymNo];
      end;
    end;
    StWord := StWord + ' ';
  end;

  procedure Triplet;
  var
    D3: integer; {сотни текущего разряда}
    D2: integer; {десятки текущего разряда}
    D1: integer; {единицы текущего разряда}
    TripletPos: integer; {смещение имени разряда для разных падежей}
  begin
    ;
    Inc(PlaceNo);
    D3 := ord(StNum[PlaceNo]) - ord('0');
    Inc(PlaceNo);
    D2 := ord(StNum[PlaceNo]) - ord('0');
    Inc(PlaceNo);
    D1 := ord(StNum[PlaceNo]) - ord('0');
    Dec(TripletNo, 3);
    TripletPos := 2; {рублей (род.п.мн.ч.)}
    if D3 > 0 then
      WordAdd(D3 + 28);
    {сотни}
    if D2 = 1 then
      WordAdd(D1 + 11)
        {10-19}
    else
    begin
      ;
      if D2 > 1 then
        WordAdd(D2 + 19);
      {десятки}
      if D1 > 0 then
      begin
        ;
        {единицы}
        if (TripletNo = 41) and (D1 < 3) then
          WordAdd(D1 - 1) {одна или две тысячи}
        else
          WordAdd(D1 + 1);
        if D1 < 5 then
          TripletPos := 1; {рубля (род.п.ед.ч.)}
        if D1 = 1 then
          TripletPos := 0; {рубль (им.п.ед.ч.)}
      end;
    end;
    if (TripletNo = 38) and (Length(StWord) = 0) then
      WordAdd(50); {ноль целых}
    if (TripletNo = 38) or (D1 + D2 + D3 > 0) then {имя разряда}
      WordAdd(TripletNo + TripletPos);
  end;

var
  i: integer;
begin
  ;
  Move(Money[StSet, 1], Sym[156], 25);
  StNum := FormatFloat(StMask, StDbl);

  PlaceNo := 0;
  TripletNo := 50;
  {47+3}
  StWord := ''; {будущий результат}

  for i := 1 to 4 do
    Triplet; {4 разряда: миллиарды, миллионы, тысячи,единицы}
  StWord := StWord + StNum[14] + StNum[15] + ' ';
  WordAdd(51);

  {Upcase первая буква}
  SpellPic := AnsiUpperCase(StWord[1]) + Copy(StWord, 2, Length(StWord) - 2);
end;

end.

Пример использования:

var
  sumpr: string;
begin
  // первый параметр - сумма, которую необходимо перевести в пропись,
  // второй параметр - валюта (0-рубли, 1- доллары).
  sumpr := spellpic(100, 0);
  ...