Code:

{ **** UBPFD *********** by delphibase.endimus ****

>> Сумма прописью

Данный набор функций позволяет из суммы в числовом виде получить

её представление прописью. Реализована возможность работы с рублями и долларами.

Возможно добавление какой угодно валюты.

Зависимости: 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] ofstring[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 shl1); {* 3}

for i := 1to3do

begin

;

Inc(CodeNo);

SymNo := ord(Code[CodeNo]) - ord('Б');

if SymNo < 0then

break;

Inc(SymNo, SymNo shl2); {* 5}

for j := 1to5do

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 > 0then

WordAdd(D3 + 28);

{сотни}

if D2 = 1then

WordAdd(D1 + 11)

{10-19}

else

begin

;

if D2 > 1then

WordAdd(D2 + 19);

{десятки}

if D1 > 0then

begin

;

{единицы}

if (TripletNo = 41) and (D1 < 3) then

WordAdd(D1 - 1) {одна или две тысячи}

else

WordAdd(D1 + 1);

if D1 < 5then

TripletPos := 1; {рубля (род.п.ед.ч.)}

if D1 = 1then

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 := 1to4do

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);

...