Delphi World - Сумма прописью - Способ 15
Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Сумма прописью - Способ 15

Автор: Евгений Меньшенин
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);
  ...
Проект Delphi World © Выпуск 2002 - 2017
Автор проекта: Эксклюзивные курсы программирования