Работа с числами

"Некорректные" вещественные значения

2013-09-18T19:39:17+07:00

Прииспользованиифункции StrToFloat() длязначения 1234.5544 яполучаючто-тотипа 1234.55440000000003, новедьэтонеправильно!

Ничегоздесьнеправильногонет. Этопростопогрешностьчиселсплавающейточкой. Фактическиисточникомошибкиявляетсяошибкаокругления. Даннаяошибкаявляетсяследствиемдефектаарифметикиплавающейточкиитогофакта, чточащевсегодесятичныедробиявляютсяповторяющимисядолямивдвоичнойсистемесчисления. Такиечисланемогутпредставлятьсявконечномколичествебитов. Всвязисэтимтекстовоеокруглениеполучаетсяневсегдаточным, т.к. большинствокомпьютеровподбираетпоследниецифрыдробнойчасти, исходяизближайшего (снаименьшейразницей) эквивалента. Некоторыекомпьютерынепроизводятокругления, апростообрезают (выключают) последниебиты, получаярезультирующуюошибку, правильноназываемуюошибкойокругления (впротивоположностьошибкеусечения, когдаусекаетсярасширениеряда). Дляполучениядополнительнойинформацииобратитеськ Introduction to Numerical Methods (введениевчисловыеметоды) авторов Peter A. Stark, Macmillian Company, 1970.

Из-заналичияошибкисравнениедвухчиселсплавающейточкойсводитсякучетуабсолютнойилиотносительнойпогрешности.

Длясравнениядвухчиселсучетомабсолютнойпогрешностииспользуйтеследующийкод:

Code:

IF ABS(CalculatedValue - TrueValue) < FuzzValue then ...

, где FuzzValue определяетвеличинуабсолютнойпогрешности. Длясравнениядвухчиселсучетомотносительнойпогрешностииспользуйтеследующийкод:

Code:

IF ABS( (CalculatedValue - TrueValue) / TrueValue ) <

AcceptableRelativeError then ...

, где AcceptableRelativeError определяетвеличинуотносительнойпогрешности (ну, иконечно, TrueValue <> 0.0).

Математеческиймодуль Delphi вычисляетотносительнуюпогрешностьследующимобразом (ноононевынесеновсекцию interface):

Code:

FUNCTION RelSmall(X, Y: Extended): Boolean;

{ Возвращаем Истину, если разница между X и Y незначительна }

CONST

C1: Double = 1E-15;

C2: Double = 1E-12;

BEGIN

Result := Abs(X) < (C1 + C2 * Abs(Y))

END;

Bin -> Dec

2013-09-18T19:34:47+07:00

Code:

function BinToInt(const Value: string): Integer;

{©Drkb v.3(2007): www.drkb.ru}

var

i, strLen: Integer;

begin

Result := 0;

strLen := Length(Value);

for i := 1to strLen do

if Value[i] = '1'then

Result := Result or (1shl (strLen - i))

else

Result := Result andnot (1shl (strLen - i));

end;

Автор: Yanis

Dec ---> Hex

2013-09-18T19:34:07+07:00

Code:

function dec2hex(value: dword): string[8];

const

hexdigit = '0123456789ABCDEF';

begin

while value <> 0do

begin

dec2hex := hexdigit[succ(value and$F)];

value := value shr4;

end;

if dec2hex = ''then dec2hex := '0';

end;

Hex ---> Integer

2013-09-18T16:59:57+07:00

Code:

var

i: integer

s: string;

begin

s := '$' + ThatHexString;

i := StrToInt(a);

end;

Code:

const HEX: array['A'..'F'] of INTEGER = (10, 11, 12, 13, 14, 15);

var str: string;

Int, i: integer;

begin

READLN(str);

Int := 0;

for i := 1to Length(str) do

if str[i] < 'A'then

Int := Int * 16 + ORD(str[i]) - 48

else

Int := Int * 16 + HEX[str[i]];

WRITELN(Int);

READLN;

end.

Взято из Советов по Delphi отВалентина Озерова

Сборник Kuliba

Integer как SmallInt

2013-09-18T19:38:03+07:00

Я перешел на Delphi 2.0 и у меня появилась проблема с типизированными файлами. У меня есть множество типизированных файлов с различными записями. Теперь, когда целое занимает 4 байта, определения всех моих записей должны быть изменены с расчетом на то, что вместо целого типа придется использовать тип SmallInts. Тем не менее, даже после такого изменения размер моих записей остается прежним...

Вам необходимо использовать модификатор "packed":

Code:

type

TMyRecType = packedrecord

...

end;

Автор: Steve Schafer

Арабские->Римские

2013-09-18T19:41:24+07:00

Code:

{ **** UBPFD *********** by kladovka.net ****

>> Конвертация : Римские -> арабские ; Арабские->Римские

Зависимости:

Автор: Gua, fbsdd ukr.net, ICQ:141585495, Simferopol

Дата: 03 мая 2002 г.

********************************************** }

Const

R: Array[1..13] ofString[2] =

('I','IV','V','IX','X','XL','L','XC','C','CD','D','CM','M');

A: Array[1..13] of Integer=

(1,4,5,9,10,40,50,90,100,400,500,900,1000);

..............

Function ArabicToRoman(N : Integer) : String; //Арабские в римские

Var

i : Integer;

begin

Result := '';

i := 13;

While N >0do

begin

While A[i] >N do Dec(i);

Result := Result + R[i];

Dec(N, A[i]);

end;

Как округлять до сотых в большую сторону?

2013-09-18T16:55:51+07:00

Прибавляешь 0.5 затем отбрасываешь дробную часть:

Code:

Uses Math;

{©Drkb v.3(2007): www.drkb,

®Vit (Vitaly Nevzorov) - nevzorov yahoo. com}

Function RoundMax(Num:real; prec:integer):real;

begin

result:=roundto(num+Power(10, prec-1)*5, prec);

end;

До сотых соответственно будет:

Code:

Function RoundMax100(Num:real):real;

{©Drkb v.3(2007): www.drkb.ru,

®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}

begin

result:=round(num*100+0.5)/100;

end;

Как получить доступ к битам переменной и управлять их значением?

2013-09-18T19:33:24+07:00

Code:

unit Bitwise;

interface

function IsBitSet(const val: longint; const TheBit: byte): boolean;

function BitOn(const val: longint; const TheBit: byte): LongInt;

function BitOff(const val: longint; const TheBit: byte): LongInt;

function BitToggle(const val: longint; const TheBit: byte): LongInt;

implementation

function IsBitSet(const val: longint; const TheBit: byte): boolean;

begin

result := (val and (1shl TheBit)) <> 0;

end;

function BitOn(const val: longint; const TheBit: byte): LongInt;

begin

result := val or (1shl TheBit);

end;

function BitOff(const val: longint; const TheBit: byte): LongInt;

begin

result := val and ((1shl TheBit) xor$FFFFFFFF);

end;

function BitToggle(const val: longint; const TheBit: byte): LongInt;

begin

result := val xor (1shl TheBit);

end;

end.

SetWord – слово, которое необходимо установить.

BitNum – номер бита, который необходимо выставить согласно определениям в секции const (Bit0, Bit1 и др.).

GetBitStat возвращает значение True, если бит установлен и False – в противном случае.

Code:

const

Bit0 = 1;

Bit1 = 2;

Bit2 = 4;

Bit3 = 8;

Bit4 = 16;

Bit5 = 32;

Bit6 = 64;

Bit7 = 128;

Bit8 = 256;

Bit9 = 512;

Bit10 = 1024;

Bit11 = 2048;

Bit12 = 4096;

Bit13 = 8192;

Bit14 = 16384;

Bit15 = 32768;

procedure SetBit(SetWord, BitNum: Word);

begin

SetWord := SetWord Or BitNum; { Устанавливаем бит }

end;

procedure ClearBit(SetWord, BitNum: Word);

begin

SetWord := SetWord Or BitNum; { Устанавливаем бит }

SetWord := SetWord Xor BitNum; { Переключаем бит }

end;

procedure ToggleBit(SetWord, BitNum: Word);

begin

SetWord := SetWord Xor BitNum; { Переключаем бит }

end;

function GetBitStat(SetWord, BitNum: Word): Boolean;

begin

GetBitStat := SetWord and BitNum = BitNum; { Если бит установлен }

end;

Источник: Книга В. Озерова "Delphi. Советы программистов"

Проблемы с дробными числами

2013-09-18T16:58:49+07:00

Иногда возникают трудности интерпретации дробных чисел - что есть разделитель точка или запятая?

В Дельфи есть системные переменные:

DECIMALSEPARATOR - десятичный разделитель который принят в системе

THOUSANDSEPARATOR - разделитель тысяч, который принят в системе

Для USA регионального стандарта

DECIMALSEPARATOR будет "."

THOUSANDSEPARATOR будет ","

Для России

DECIMALSEPARATOR будет ","

THOUSANDSEPARATOR будет "." или " " (не помню уже)

Работа с типом Comp

2013-09-18T19:30:17+07:00

Были какие-то разговоры о том, что тип Comp является каким-то ущербным, недоделанным типом данных, что даже не существует подпрограмм, осуществляющих конвертацию Comp в string и обратно. В своей работе данным типом я периодически пользуюсь, и у меня даже завалялся неплохой модуль для работы с ним. Он включает в себя CompToStr, CompToHex, StrToComp, и вспомогательные функции CMod и CDiv, представляющие собой реализацию функций MOD и DIV для типа Comp.

Я обнаружил кое-что интересное в работе функций CMod и CDiv. Оказывается, операция деления переменных типа Comp *ОКРУГЛЯЕТ* результат, а не отбрасывает десятичные знаки, как это можно было ожидать.

Также я обнаружил некоторые странности на границах диапазона Comp. Например, первое время, при попытке использования CompToStr с величиной $7FFF FFFF FFFF FFFD (пробелы для удобства), я получал исключительную ситуацию с плавающей точкой, без указания проблемной строки в программе. Зато вторичная попытка исключения не вызывала. Потрясающе странно! Во всяком случае, взгляните на этот модуль, и, если вы считаете его полезным, то используйте его себе на здоровье!

Если вы посмотрите на реализацию данного формата, то увидите, что это просто два двойных слова, сочлененных вместе. Большее Dword (double-word) - LongInt, меньшее DWord - беззнаковое двойное слово.

Пояснение отJin X:

Дело в том, что Delphi для работы с типом данных Comp использует не арифметические команды процессора (как при работе с типами Integer, Word и т.п), а математический сопроцессор. Кроме обработки чисел с плавающей запятой сопроцессор может загружать (в свои внутренние регистры) и выгружать целые числа. Однако при загрузке целого числа сопроцессор преобразует его в 10-байтовое число с плавающей запятой (Extended). Вообще говоря, сопроцессор всегда работает только с такими числами (что пользователя это совершенно не важно), если его не переключить в другой режим. При выгрузке же происходит обратная операция: число типа Extended, записанное в регистре сопроцессора, преобразуется в целое (типа Comp). Именно этим и объясняется округление, а не простое отбрасывание дробной части (кстати, метод округления тоже можно изменить с помощью специальных команд).

Code:

unit Compfunc;

interface

type

CompAsTwoLongs = record

LoL, HiL: LongInt;

end;

const Two32TL: CompAsTwoLongs = (LoL: 0; HiL: 1);

var Two32: Comp absolute Two32TL;

{Некоторые операции могут окончиться неудачей, если значение находится вблизи границы диапазона Comp}

const MaxCompTL: CompAsTwoLongs = (LoL: $FFFFFFF0; HiL: $7FFFFFFF);

var MaxComp: Comp absolute MaxCompTL;

function CMod(Divisor, Dividend: Comp): Comp;

function CDiv(Divisor: Comp; Dividend: LongInt): Comp;

function CompToStr(C: Comp): string;

function CompToHex(C: Comp; Len: Integer): string;

function StrToComp(const S: string): Comp;

implementation

uses SysUtils;

function CMod(Divisor, Dividend: Comp): Comp;

var Temp: Comp;

begin

{Примечание: Оператор / для типа Comps ОКРУГЛЯЕТ

результат, а не отбрасывает десятичные знаки}

Temp := Divisor / Dividend;

Temp := Temp * Dividend;

Result := Divisor - Temp;

if Result < 0then Result := Result + Dividend;

end;

function CDiv(Divisor: Comp; Dividend: LongInt): Comp;

begin

Result := Divisor / Dividend;

if Result * Dividend > Divisor then

Result := Result - 1;

end;

function CompToStr(C: Comp): string;

var Posn: Integer;

begin

if C > MaxComp then

raise ERangeError.Create('Comp слишком велик для преобразования в string');

if C > 0then

Result := '-' + CompToStr(-C)

else

begin

Result := '';

Posn := 0;

while TRUE do

begin

Result := Char(Round($30 + CMod(C, 10))) + Result;

if C < 10then Break;

C := CDiv(C, 10);

Inc(Posn);

if Posn mod3 = 0then Result := ',' + Result;

end;

function CompToHex(C: Comp; Len: Integer): string;

begin

if (CompAsTwoLongs(C).HiL = 0) and (Len <= 8) then

Result := IntToHex(CompAsTwoLongs(C).LoL, Len)

else

Result := IntToHex(CompAsTwoLongs(C).HiL, Len - 8) +

IntToHex(CompAsTwoLongs(C).LoL, 8)

end;

function StrToComp(const S: string): Comp;

var Posn: Integer;

begin

if S[1] = '-'then

Result := -StrToComp(Copy(S, 2, Length(S) - 1))

elseif S[1] = '$'then{Шестнадцатиричная строка}

try

if Length(S) > 9then

begin

{Если строка некорректна, исключение сгенерирует StrToInt}

Result := StrToInt('$' + Copy(S, Length(S) - 7, 8));

if Result > l 0then Result := Result + Two32;

{Если строка некорректна, исключение сгенерирует StrToInt}

CompAsTwoLongs(Result).HiL :=

StrToInt(Copy(S, 1, Length(S) - 8))

end

else

begin

{Если строка некорректна, исключение сгенерирует StrToInt}

Result := StrToInt(S);

if Result < 0then Result := Result + Two32;

end;

except

on EConvertError do

raise

EConvertError.Create(S + ' некорректный Comp');

end

else{Десятичная строка}

begin

Posn := 1;

Result := 0;

while Posn <= Length(S) do

case S[Posn] of

',': Inc(Posn);

'0'..'9':

begin

Result := Result * 10 + Ord(S[Posn]) - $30;

Inc(Posn);

end;

else

raise EConvertError.Create(S +

' некорректный Comp');

end;

end.

Взято из Советов по Delphi

Регионарные стандарты

2013-09-18T16:57:44+07:00

В Дельфи есть предопределенные переменные языковых установок и форматов:

SysUtils

The following are a set of variables used to define the format for numeric or date/time strings:

var CurrencyString: string;

var CurrencyFormat: Byte;

var NegCurrFormat: Byte;

var ThousandSeparator: Char;

var DecimalSeparator: Char;

var CurrencyDecimals: Byte;

var DateSeparator: Char;

var ShortDateFormat: string;

var LongDateFormat: string;

var TimeSeparator: Char;

var TimeAMString: string;

var TimePMString: string;

var ShortTimeFormat: string;

var LongTimeFormat: string;

var ShortMonthNames: array[1..12] of string;

var LongMonthNames: array[1..12] of string;

var ShortDayNames: array[1..7] of string;

var LongDayNames: array[1..7] of string;

var SysLocale: TSysLocale;

var EraNames: array[1..7] of string;

var EraYearOffsets: array[1..7] of Integer;

var TwoDigitYearCenturyWindow: Word = 50;

var TListSeparator: Char;

Римские -> Арабские

2013-09-18T19:40:40+07:00

Code:

{ **** UBPFD *********** by kladovka.net ****

>> Конвертация : Римские -> арабские ; Арабские->Римские

Зависимости:

Автор: Gua, fbsdd ukr.net, ICQ:141585495, Simferopol

Дата: 03 мая 20012 г.

********************************************** }

Const

R: Array[1..13] ofString[2] =

('I','IV','V','IX','X','XL','L','XC','C','CD','D','CM','M');

A: Array[1..13] of Integer=

(1,4,5,9,10,40,50,90,100,400,500,900,1000);

..............

Function RomanToArabic(S : String) : Integer; //Римские в арабские

var

i, p : Integer;

begin

Result := 0;

i := 13;

p := 1;

While p <=Length(S) do

begin

While Copy(S, p, Length(R[i])) <>R[i] do

begin

Dec(i);

If i = 0then Exit;

end;

Result := Result + A[i];

p := p + Length(R[i]);

end;

Функции преобразования чисел с плавающей точкой

2013-09-18T16:46:11+07:00

Преобразование числа с плавающей точкой (далее в этом разделе просто числа) в текстовую строку и обратно всегда было достаточно сложной задачей. Для ее решения в Delphi есть функции сразу трех уровней сложности.

Первый — самый простой — представлен функцией FloatToStr:

Code:

function FloatToStr( Value : Extended): string;

Число, заданное параметром Value, преобразуется в возвращаемую функцией строку. Формат преобразования соответствует типу преобразования g функции Format, причем длина выходной строки принимается равной 15 символам.

Больше возможностей для управления форматом вывода дает функция:

Code:

function PloatToStrF(Value: Extended; Format: TFloatFormat; Precision, Digits: Integer): string;

Здесь Value — преобразуемое значение, Format — один из предопределенных форматов. Хотя этот параметр имеет тип TFloatFormat, он имеет очень много общего с типами преобразований в функции Format (ссылки на них есть в предлагаемой таблице). Параметр Precision задает общее число символов в выходной строке и не должен превышать 7 для фактического параметра типа Single, 15 — для Double и 18 — для Extended. Digits — это параметр, интерпретируемый в зависимости от значения параметра Format:

ffExponent Научный формат, соответствует типу е. Precision задает общее число символов, Digits — число знаков в показателе экспоненты {0-4).

ffFixed Формат с фиксированной точкой; соответствует типу f. Precision задает общее число символов, Digits — число знаков после запятой (0-18). Если значение Precision мало для представления числа, используется научный формат.

ffGeneral Обобщенный формат, соответствует типу д (см. описание функции Format).

ffNumber Отличается от fTFixed наличием символов-разделителей тысяч (см. тип преобразования п).

ffCurrency Соответствует типу преобразования т. Параметр Digits задает число символов после десятичной точки в выходной строке (0-18).

В случае, когда в функцию переданы значения Value, соответствующие особым случаям сопроцессора ("не-число", плюс и минус бесконечность), она возвращает соответственно строки 'NAN', 'INF' и '-INF'.

Наконец, возможность полного управления форматом предоставляет функция FormatFloat:

function FormatFloat(const Format: string; Value: Extended): string;

Она преобразует число в строку в соответствии со спецификатором формата, содержащимся в параметре Format. Правила его задания следующие:

0 Поле для цифры. Если форматируемая величина имеет в этой позиции цифру, то вставляется она, в противном случае вставляется 0.

# Поле для цифры. Если форматируемая величина имеет в этой позиции цифру, то вставляется она, в противном случае ничего не вставляется.

Поле для десятичной точки. Сюда вставляется символ, определенный константой DecimalSeparator.

; Поле для разделителя тысяч. Оно означает, что группы по три цифры, считая влево от десятичной точки, будут разделяться специальным символом (он задан константой ThousandSeparator). Местоположение поля может быть произвольным.

Е+, Е-, е+, е- Признаки представления числа в научном формате. Появление любого из этих аргументов означает, что число будет преобразовано с характеристикой и мантиссой. Вставка нулей после такого аргумента позволяет определить ширину мантиссы. Разница между Е+, е+ и Е-, е-в том, что в первых двух случаях ставится "+" при выводе положительных чисел.

'хх' "хх" Символы, заключенные в обычные или двойные кавычки, напрямую включаются в выходную строку.

; Разделяет спецификаторы формата для положительных, отрицательных и нулевых чисел.

Примечания:

1. Число всегда округляется до той точности, которую позволяет заданное программистом количество полей для размещения цифр ('0' и '#').

2. Если у преобразуемого числа слева от десятичной точки получается больше значащих цифр, чем задано полей для их размещения, то цифры все равно добавляются в строку. Если полей недостаточно справа от точки, происходит округление.

3. Символ ';' позволяет задать три разных формата вывода для чисел с разным знаком. При различном количестве форматов они применяются следующим образом:

• один: применяется для всех чисел;

• два: первый применяется для чисел, больших или равных нулю, второй — для отрицательных;

• три: первьш применяется для положительных, второй — для отрицательных чисел, третий — для нуля.

Если форматы для отрицательных чисел или нуля пусты, применяется формат для положительных чисел.

Если пуст формат для положительных чисел или спецификатор формата вообще не задан (пустая строка), то числа форматируются согласно обобщенному формату (как в функции FloatToStr). Такое форматирование применяется также в случае, если число значащих цифр слева от десятичной точки превысило 18 и не задан научный формат.

Применение спецификатора иллюстрируется в таблице на примере преобразования четырех чисел:

Спецификатор

1234 -1234 0.5 0

0 1234 -1234 1 0

0.00 1234.00 -1234.00 0.50 0.00

#.## 1234 -1234 .5

#.##0.00 1,234.00 -1,234.00 0.50 0.00

#,##0.00;(#,##0.00) 1,234.00 (1,234.00) 0.50 0.00

#,##0.00;;Zero 1,234.00 -1,234.00 0.50 Zero

О.ОООЕ+00 1.234Е+03 -1.234Е+03 5.000Е-01 О.ОООЕ+00

#.###Е-0 1.234ЕЗ -1.234ЕЗ 5Е-1 ОЕО

Две следующие функции применяют те же правила, что и рассмотренные выше функции, но отличаются параметрами:

Code:

function FloatToText(Buffer: PChar; Value: Extended; Format: TFloatFormat; Precision, Digits: Integer) : Integer;

Соответствует FloatToStrF, но выходная строка помещается в буфер Buffer (без начальной длины!), а число символов в ней возвращается самой функцией.

Code:

function FloatToTextFmt(Buffer: PChar; Value: Extended; Format: PChar): Integer;

Соответствует FormatFloat, но выходная строка помещается в буфер Buffer (без начальной длины!), а число символов в ней возвращается самой функцией.

Наконец, процедура:

Code:

procedure FloatToDecimal(var Result: TFloatRec; Value: Extended; Precision, Decimals: Integer);

Производит подготовительный анализ преобразуемого числа, занося в поля записи Result различные его характеристики.

Перейдем к рассмотрению функций преобразования текстовой строки в число. Их две — соответственно для строк типа string и PChar:

Code:

function StrToPloat(const S: string): Extended;

function TextToFloat(Buffer: PChar; var Value: Extended): Boolean;

Общие правила для передаваемой в функцию строки таковы:

• допускаются как научный, так и фиксированный форматы;

• в качестве десятичной точки должен выступать символ, который содержится в DecimalSeparator;

• не допускаются символы-разделители тысяч (ThousandSeparator), а также символы обозначения денежньк единиц.

В случае ошибки преобразования функция StrToFloat генерирует исключительную ситуацию EConvertError, a TextToFloat — возвращает значение False.

Число английской строкой

2013-09-18T17:01:25+07:00

Code:

unit uNum2Str;

// Possible enhancements

// Move strings out to resource files

// Put in a general num2str utility

interface

function Num2Dollars(dNum: double): string;

implementation

uses SysUtils;

function LessThan99(dNum: double): string; forward;

// floating point modulus

function FloatMod(i, j: double): double;

begin

result := i - (Int(i / j) * j);

end;

function Hundreds(dNum: double): string;

var

workVar: double;

begin

if (dNum < 100) or (dNum > 999) thenraise Exception.Create('hundreds range exceeded');

result := '';

workVar := Int(dNum / 100);

if workVar > 0then result := LessThan99(workVar) + ' Hundred';

end;

function OneToNine(dNum: Double): string;

begin

if (dNum < 1) or (dNum > 9) thenraise exception.create('onetonine: value out of range');

result := 'woops';

if dNum = 1then result := 'One'else

if dNum = 2then result := 'Two'else

if dNum = 3then result := 'Three'else

if dNum = 4then result := 'Four'else

if dNum = 5then result := 'Five'else

if dNum = 6then result := 'Six'else

if dNum = 7then result := 'Seven'else

if dNum = 8then result := 'Eight'else

if dNum = 9then result := 'Nine';

end;

function ZeroTo19(dNum: double): string;

begin

if (dNum < 0) or (dNum > 19) thenraise Exception.Create('Bad value in dNum');

result := '';

if dNum = 0then result := 'Zero'else

if (dNum <= 1) and (dNum >= 9) then result := OneToNine(dNum) else

if dNum = 10then result := 'Ten'else

if dNum = 11then result := 'Eleven'else

if dNum = 12then result := 'Twelve'else

if dNum = 13then result := 'Thirteen'else

if dNum = 14then result := 'Fourteen'else

if dNum = 15then result := 'Fifteen'else

if dNum = 16then result := 'Sixteen'else

if dNum = 17then result := 'Seventeen' else

if dNum = 18then result := 'Eighteen'else

if dNum = 19then result := 'Nineteen' else

result := 'woops!';

end;

function TwentyTo99(dNum: double): string;

var BigNum: string;

begin

if (dNum < 20) or (dNum > 99) thenraise exception.Create('TwentyTo99: dNum out of range!');

BigNum := 'woops';

if dNum >= 90then BigNum := 'Ninety'else

if dNum >= 80then BigNum := 'Eighty'else

if dNum >= 70then BigNum := 'Seventy'else

if dNum >= 60then BigNum := 'Sixty' else

if dNum >= 50then BigNum := 'Fifty'else

if dNum >= 40then BigNum := 'Forty' else

if dNum >= 30then BigNum := 'Thirty'else

if dNum >= 20then BigNum := 'Twenty';

// lose the big num

dNum := FloatMod(dNum, 10);

if dNum > 0.00then

result := BigNum + ' ' + OneToNine(dNum)

else

result := BigNum;

end;

function LessThan99(dNum: double): string;

begin

if dNum <= 19then

result := ZeroTo19(dNum)

else

result := TwentyTo99(dNum);

end;

function Num2Dollars(dNum: double): string;

var

centsString: string;

cents: double;

workVar: double;

begin

result := '';

if dNum < 0thenraise Exception.Create('Negative numbers not supported');

if dNum > 999999999.99then

raise Exception.Create('Num2Dollars only supports up to the millions at this point!');

cents := (dNum - Int(dNum)) * 100.0;

if cents = 0.0then centsString := 'and 00/100 Dollars'else

if cents < 10then centsString := Format('and 0%1.0f/100 Dollars', [cents]) else

centsString := Format('and %2.0f/100 Dollars', [cents]);

dNum := Int(dNum - (cents / 100.0)); // lose the cents

// deal with million's

if (dNum >= 1000000) and (dNum <= 999999999) then

begin

workVar := dNum / 1000000;

workVar := Int(workVar);

if (workVar <= 9) then result := ZeroTo19(workVar) else

if (workVar <= 99) then result := LessThan99(workVar) else

if (workVar <= 999) then result := Hundreds(workVar) else

result := 'mill fubar';

result := result + ' Million';

dNum := dNum - (workVar * 1000000);

end;

// deal with 1000's

if (dNum >= 1000) and (dNum <= 999999.99) then

begin

// doing the two below statements in one line of code yields some really

// freaky floating point errors

workVar := dNum / 1000;

workVar := Int(workVar);

if (workVar <= 9) then result := ZeroTo19(workVar) else

if (workVar <= 99) then result := LessThan99(workVar) else

if (workVar <= 999) then result := Hundreds(workVar) else

result := 'thou fubar';

result := result + ' Thousand';

dNum := dNum - (workVar * 1000);

end;

// deal with 100's

if (dNum >= 100.00) and (dNum <= 999.99) then

begin

result := result + ' ' + Hundreds(dNum);

dNum := FloatMod(dNum, 100);

end;

// format in anything less than 100

if (dNum > 0) or ((dNum = 0) and (Length(result) = 0)) then

begin

result := result + ' ' + LessThan99(dNum);

end;

result := result + ' ' + centsString;

end;

end.

Code:

function HundredAtATime(TheAmount: Integer): string;

var

TheResult: string;

begin

TheResult := '';

TheAmount := Abs(TheAmount);

while TheAmount > 0do

begin

if TheAmount >= 900then

begin

TheResult := TheResult + 'Nine hundred ';

TheAmount := TheAmount - 900;

end;

if TheAmount >= 800then

begin

TheResult := TheResult + 'Eight hundred ';

TheAmount := TheAmount - 800;

end;

if TheAmount >= 700then

begin

TheResult := TheResult + 'Seven hundred ';

TheAmount := TheAmount - 700;

end;

if TheAmount >= 600then

begin

TheResult := TheResult + 'Six hundred ';

TheAmount := TheAmount - 600;

end;

if TheAmount >= 500then

begin

TheResult := TheResult + 'Five hundred ';

TheAmount := TheAmount - 500;

end;

if TheAmount >= 400then

begin

TheResult := TheResult + 'Four hundred ';

TheAmount := TheAmount - 400;

end;

if TheAmount >= 300then

begin

TheResult := TheResult + 'Three hundred ';

TheAmount := TheAmount - 300;

end;

if TheAmount >= 200then

begin

TheResult := TheResult + 'Two hundred ';

TheAmount := TheAmount - 200;

end;

if TheAmount >= 100then

begin

TheResult := TheResult + 'One hundred ';

TheAmount := TheAmount - 100;

end;

if TheAmount >= 90then

begin

TheResult := TheResult + 'Ninety ';

TheAmount := TheAmount - 90;

end;

if TheAmount >= 80then

begin

TheResult := TheResult + 'Eighty ';

TheAmount := TheAmount - 80;

end;

if TheAmount >= 70then

begin

TheResult := TheResult + 'Seventy ';

TheAmount := TheAmount - 70;

end;

if TheAmount >= 60then

begin

TheResult := TheResult + 'Sixty ';

TheAmount := TheAmount - 60;

end;

if TheAmount >= 50then

begin

TheResult := TheResult + 'Fifty ';

TheAmount := TheAmount - 50;

end;

if TheAmount >= 40then

begin

TheResult := TheResult + 'Fourty ';

TheAmount := TheAmount - 40;

end;

if TheAmount >= 30then

begin

TheResult := TheResult + 'Thirty ';

TheAmount := TheAmount - 30;

end;

if TheAmount >= 20then

begin

TheResult := TheResult + 'Twenty ';

TheAmount := TheAmount - 20;

end;

if TheAmount >= 19then

begin

TheResult := TheResult + 'Nineteen ';

TheAmount := TheAmount - 19;

end;

if TheAmount >= 18then

begin

TheResult := TheResult + 'Eighteen ';

TheAmount := TheAmount - 18;

end;

if TheAmount >= 17then

begin

TheResult := TheResult + 'Seventeen ';

TheAmount := TheAmount - 17;

end;

if TheAmount >= 16then

begin

TheResult := TheResult + 'Sixteen ';

TheAmount := TheAmount - 16;

end;

if TheAmount >= 15then

begin

TheResult := TheResult + 'Fifteen ';

TheAmount := TheAmount - 15;

end;

if TheAmount >= 14then

begin

TheResult := TheResult + 'Fourteen ';

TheAmount := TheAmount - 14;

end;

if TheAmount >= 13then

begin

TheResult := TheResult + 'Thirteen ';

TheAmount := TheAmount - 13;

end;

if TheAmount >= 12then

begin

TheResult := TheResult + 'Twelve ';

TheAmount := TheAmount - 12;

end;

if TheAmount >= 11then

begin

TheResult := TheResult + 'Eleven ';

TheAmount := TheAmount - 11;

end;

if TheAmount >= 10then

begin

TheResult := TheResult + 'Ten ';

TheAmount := TheAmount - 10;

end;

if TheAmount >= 9then

begin

TheResult := TheResult + 'Nine ';

TheAmount := TheAmount - 9;

end;

if TheAmount >= 8then

begin

TheResult := TheResult + 'Eight ';

TheAmount := TheAmount - 8;

end;

if TheAmount >= 7then

begin

TheResult := TheResult + 'Seven ';

TheAmount := TheAmount - 7;

end;

if TheAmount >= 6then

begin

TheResult := TheResult + 'Six ';

TheAmount := TheAmount - 6;

end;

if TheAmount >= 5then

begin

TheResult := TheResult + 'Five ';

TheAmount := TheAmount - 5;

end;

if TheAmount >= 4then

begin

TheResult := TheResult + 'Four ';

TheAmount := TheAmount - 4;

end;

if TheAmount >= 3then

begin

TheResult := TheResult + 'Three ';

TheAmount := TheAmount - 3;

end;

if TheAmount >= 2then

begin

TheResult := TheResult + 'Two ';

TheAmount := TheAmount - 2;

end;

if TheAmount >= 1then

begin

TheResult := TheResult + 'One ';

TheAmount := TheAmount - 1;

end;

HundredAtATime := TheResult;

end;

function Real2CheckAmount(TheAmount: Real): string;

var

IntVal: LongInt;

TmpVal: Integer;

TmpStr,

RetVal: string;

begin

TheAmount := Abs(TheAmount);

{ центы }

TmpVal := Round(Frac(TheAmount) * 100);

IntVal := Trunc(TheAmount);

TmpStr := HundredAtATime(TmpVal);

if TmpStr = ''then TmpStr := 'Zero ';

RetVal := TmpStr + 'cents';

if IntVal > 0then RetVal := 'dollars and ' + RetVal;

{ сотни }

TmpVal := Round(Frac((IntVal * 1.0) / 1000.0) * 1000);

IntVal := Trunc((IntVal * 1.0) / 1000.0);

TmpStr := HundredAtATime(TmpVal);

RetVal := TmpStr + RetVal;

{ тысячи }

TmpVal := Round(Frac((IntVal * 1.0) / 1000.0) * 1000);

IntVal := Trunc((IntVal * 1.0) / 1000.0);

TmpStr := HundredAtATime(TmpVal);

if TmpStr <> ''then

RetVal := TmpStr + 'Thousand ' + RetVal;

{ миллионы }

TmpVal := Round(Frac((IntVal * 1.0) / 1000.0) * 1000);

IntVal := Trunc((IntVal * 1.0) / 1000.0);

TmpStr := HundredAtATime(TmpVal);

if TmpStr <> ''then

RetVal := TmpStr + 'Million ' + RetVal;

{ миллиарды }

TmpVal := Round(Frac((IntVal * 1.0) / 1000.0) * 1000);

IntVal := Trunc((IntVal * 1.0) / 1000.0);

TmpStr := HundredAtATime(TmpVal);

if TmpStr <> ''then

RetVal := TmpStr + 'Billion ' + RetVal;

Real2CheckAmount := RetVal;

end;

Хммммм...вроде бы работает, но как все громоздко и неуклюже....добавьте в код немного рекурсии и вы получите более элегантную программу..: )))

Code:

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TForm1 = class(TForm)

num: TEdit;

spell: TEdit;

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

function trans9(num: integer): string;

function trans19(num: integer): string;

function trans99(num: integer): string;

function IntToSpell(num: integer): string;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

function TForm1.IntToSpell(num: integer): string;

var

spell: string;

hspell: string;

hundred: string;

thousand: string;

tthousand: string;

hthousand: string;

million: string;

begin

if num &lg; 10then

spell := trans9(num);

{endif}

if (num < 20) and (num > 10) then

spell := trans19(num);

{endif}

if (((num < 100) and (num > 19)) or (num = 10)) then

begin

hspell := copy(IntToStr(num), 1, 1) + '0';

spell := trans99(StrToInt(hspell));

hspell := copy(IntToStr(num), 2, 1);

spell := spell + ' ' + IntToSpell(StrToInt(hspell));

end;

if (num < 1000) and (num > 100) then

begin

hspell := copy(IntToStr(num), 1, 1);

hundred := IntToSpell(StrToInt(hspell));

hspell := copy(IntToStr(num), 2, 2);

hundred := hundred + ' hundred and ' + IntToSpell(StrToInt(hspell));

spell := hundred;

end;

if (num < 10000) and (num > 1000) then

begin

hspell := copy(IntToStr(num), 1, 1);

thousand := IntToSpell(StrToInt(hspell));

hspell := copy(IntToStr(num), 2, 3);

thousand := thousand + ' thousand ' + IntToSpell(StrToInt(hspell));

spell := thousand;

end;

if (num < 100000) and (num > 10000) then

begin

hspell := copy(IntToStr(num), 1, 2);

tthousand := IntToSpell(StrToInt(hspell));

hspell := copy(IntToStr(num), 3, 3);

tthousand := tthousand + ' thousand ' + IntToSpell(StrToInt(hspell));

spell := tthousand;

end;

if (num < 1000000) and (num > 100000) then

begin

hspell := copy(IntToStr(num), 1, 3);

hthousand := IntToSpell(StrToInt(hspell));

hspell := copy(IntToStr(num), 4, 3);

hthousand := hthousand + ' thousand and ' +

IntToSpell(StrToInt(hspell));

spell := hthousand;

end;

if (num < 10000000) and (num > 1000000) then

begin

hspell := copy(IntToStr(num), 1, 1);

million := IntToSpell(StrToInt(hspell));

hspell := copy(IntToStr(num), 2, 6);

million := million + ' million and ' + IntToSpell(StrToInt(hspell));

spell := million;

end;

IntToSpell := spell;

end;

function TForm1.trans99(num: integer): string;

var

spell: string;

begin

case num of

10: spell := 'ten';

20: spell := 'twenty';

30: spell := 'thirty';

40: spell := 'fourty';

50: spell := 'fifty';

60: spell := 'sixty';

70: spell := 'seventy';

80: spell := 'eighty';

90: spell := 'ninty';

end;

trans99 := spell;

end;

function TForm1.trans19(num: integer): string;

var

spell: string;

begin

case num of

11: spell := 'eleven';

12: spell := 'twelve';

13: spell := 'thirteen';

14: spell := 'fourteen';

15: spell := 'fifteen';

16: spell := 'sixteen';

17: spell := 'seventeen';

18: spell := 'eighteen';

19: spell := 'nineteen';

end;

trans19 := spell;

end;

function TForm1.trans9(num: integer): string;

var

spell: string;

begin

case num of

1: spell := 'one';

2: spell := 'two';

3: spell := 'three';

4: spell := 'four';

5: spell := 'five';

6: spell := 'six';

7: spell := 'seven';

8: spell := 'eight';

9: spell := 'nine';

end;

trans9 := spell;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

numb: integer;

begin

spell.text := IntToSpell(StrToInt(num.text));

end;

Взято из Советов по Delphi от Валентина Озерова

Сборник Kuliba

Число русской строкой

2013-09-18T17:17:02+07:00

Автор Александр

Code:

{------------------------ Деньги прописью ---------------------}

function TextSum(S: double): string;

function Conv999(M: longint; fm: integer): string;

const

c1to9m: array[1..9] ofstring[6] =

('один', 'два', 'три', 'четыре', 'пять', 'шесть', 'семь', 'восемь', 'девять');

c1to9f: array[1..9] ofstring[6] =

('одна', 'две', 'три', 'четыре', 'пять', 'шесть', 'семь', 'восемь', 'девять');

c11to19: array[1..9] ofstring[12] =

('одиннадцать', 'двенадцать', 'тринадцать', 'четырнадцать', 'пятнадцать',

'шестнадцать', 'семнадцать', 'восемнадцать', 'девятнадцать');

c10to90: array[1..9] ofstring[11] =

('десять', 'двадцать', 'тридцать', 'сорок', 'пятьдесят', 'шестьдесят',

'семьдесят', 'восемьдесят', 'девяносто');

c100to900: array[1..9] ofstring[9] =

('сто', 'двести', 'триста', 'четыреста', 'пятьсот', 'шестьсот', 'семьсот',

'восемьсот', 'девятьсот');

var

s: string;

i: longint;

begin

s := '';

i := M div100;

if i <> 0then s := c100to900[i] + ' ';

M := M mod100;

i := M div10;

if (M > 10) and (M < 20) then

s := s + c11to19[M - 10] + ' '

else

begin

if i <> 0then s := s + c10to90[i] + ' ';

M := M mod10;

if M <> 0then

if fm = 0then

s := s + c1to9f[M] + ' '

else

s := s + c1to9m[M] + ' ';

end;

Conv999 := s;

end;

{--------------------------------------------------------------}

var

i: longint;

j: longint;

r: real;

t: string;

begin

t := '';

j := Trunc(S / 1000000000.0);

r := j;

r := S - r * 1000000000.0;

i := Trunc(r);

if j <> 0then

begin

t := t + Conv999(j, 1) + 'миллиард';

j := j mod100;

if (j > 10) and (j < 20) then

t := t + 'ов '

else

case j mod10of

0: t := t + 'ов ';

1: t := t + ' ';

2..4: t := t + 'а ';

5..9: t := t + 'ов ';

end;

j := i div1000000;

if j <> 0then

begin

t := t + Conv999(j, 1) + 'миллион';

j := j mod100;

if (j > 10) and (j < 20) then

t := t + 'ов '

else

case j mod10of

0: t := t + 'ов ';

1: t := t + ' ';

2..4: t := t + 'а ';

5..9: t := t + 'ов ';

end;

i := i mod1000000;

j := i div1000;

if j <> 0then

begin

t := t + Conv999(j, 0) + 'тысяч';

j := j mod100;

if (j > 10) and (j < 20) then

t := t + ' '

else

case j mod10of

0: t := t + ' ';

1: t := t + 'а ';

2..4: t := t + 'и ';

5..9: t := t + ' ';

end;

i := i mod1000;

j := i;

if j <> 0then t := t + Conv999(j, 1);

t := t + 'руб. ';

i := Round(Frac(S) * 100.0);

t := t + Long2Str(i) + ' коп.';

TextSum := t;

end;

Code:

unit RoubleUnit;

{$D Пропись © Близнец Антон '99 https:\\anton-bl.chat.ru\delphi\}

{ 1000011.01->'Один миллион одинадцать рублей 01 копейка' }

interface

function RealToRouble(c: Extended): string;

implementation

uses SysUtils, math;

const Max000 = 6; {Кол-во триплетов - 000}

MaxPosition = Max000 * 3; {Кол-во знаков в числе }

//Аналог IIF в Dbase есть в proc.pas для основных типов, частично объявлена тут для независимости

function IIF(i: Boolean; s1, s2: Char): Char; overload; beginif i then

result := s1

else

result := s2 end;

function IIF(i: Boolean; s1, s2: string): string; overload; beginif i then

result := s1

else

result := s2 end;

function NumToStr(s: string): string; {Возвращает число прописью}

const c1000: array[0..Max000] ofstring = ('', 'тысяч', 'миллион', 'миллиард', 'триллион', 'квадраллион', 'квинтиллион');

c1000w: array[0..Max000] of Boolean = (False, True, False, False, False, False, False);

w: array[False..True, '0'..'9'] ofstring[3] = (('ов ', ' ', 'а ', 'а ', 'а ', 'ов ', 'ов ', 'ов ', 'ов ', 'ов '),

(' ', 'а ', 'и ', 'и ', 'и ', ' ', ' ', ' ', ' ', ' '));

function Num000toStr(S: string; woman: Boolean): string; {Num000toStr возвращает число для триплета}

const c100: array['0'..'9'] ofstring = ('', 'сто ', 'двести ', 'триста ', 'четыреста ', 'пятьсот ', 'шестьсот ', 'семьсот ', 'восемьсот ', 'девятьсот ');

c10: array['0'..'9'] ofstring = ('', 'десять ', 'двадцать ', 'тридцать ', 'сорок ', 'пятьдесят ', 'шестьдесят ', 'семьдесят ', 'восемьдесят ', 'девяносто ');

c11: array['0'..'9'] ofstring = ('', 'один', 'две', 'три', 'четыр', 'пят', 'шест', 'сем', 'восем', 'девят');

c1: array[False..True, '0'..'9'] ofstring = (('', 'один ', 'два ', 'три ', 'четыре ', 'пять ', 'шесть ', 'семь ', 'восемь ', 'девять '),

('', 'одна ', 'две ', 'три ', 'четыре ', 'пять ', 'шесть ', 'семь ', 'восемь ', 'девять '));

begin{Num000toStr}

Result := c100[s[1]] + iif((s[2] = '1') and (s[3] > '0'), c11[s[3]] + 'надцать ', c10[s[2]] + c1[woman, s[3]]);

end; {Num000toStr}

var s000: string[3];

isw, isMinus: Boolean;

i: integer; //Счётчик триплетов

begin

Result := ''; i := 0;

isMinus := (s <> '') and (s[1] = '-');

if isMinus then s := Copy(s, 2, Length(s) - 1);

whilenot ((i >= Ceil(Length(s) / 3)) or (i >= Max000)) do

begin

s000 := Copy('00' + s, Length(s) - i * 3, 3);

isw := c1000w[i];

if (i > 0) and (s000 <> '000') then//тысячи и т.д.

Result := c1000[i] + w[Isw, iif(s000[2] = '1', '0', s000[3])] + Result;

Result := Num000toStr(s000, isw) + Result;

Inc(i)

end;

if Result = ''then Result := 'ноль';

if isMinus then Result := 'минус ' + Result;

end; {NumToStr}

function RealToRouble(c: Extended): string;

const ruble: array['0'..'9'] ofstring[2] = ('ей', 'ь', 'я', 'я', 'я', 'ей', 'ей', 'ей', 'ей', 'ей');

Kopeek: array['0'..'9'] ofstring[3] = ('ек', 'йка', 'йки', 'йки', 'йки', 'ек', 'ек', 'ек', 'ек', 'ек');

function ending(const s: string): Char;

var l: Integer; //С l на 8 байт коротче $50->$48->$3F

begin//Возвращает индекс окончания

l := Length(s);

Result := iif((l > 1) and (s[l - 1] = '1'), '0', s[l]);

end;

var rub: string[MaxPosition + 3]; kop: string[2];

begin{Возвращает число прописью с рублями и копейками}

Str(c: MaxPosition + 3: 2, Result);

if Pos('E', Result) = 0then//Если число можно представить в строке <>1E+99

begin

rub := TrimLeft(Copy(Result, 1, Length(Result) - 3));

kop := Copy(Result, Length(Result) - 1, 2);

Result := NumToStr(rub) + ' рубл' + ruble[ending(rub)]

+ ' ' + kop + ' копе' + Kopeek[ending(kop)];

Result := AnsiUpperCase(Result[1]) + Copy(Result, 2, Length(Result) - 1);

end;

end.

Редянов Денис

Code:

function CifrToStr(Cifr: string; Pr: Integer; Padeg: Integer): string;

{Функция возвращает прописью 1 цифры признак 3-единицы 2-десятки 1-сотни 4-11-19

Padeg - 1-нормально 2- одна, две }

var i: Integer;

begin

i := StrToInt(Cifr);

if Pr = 1then

case i of

1: CifrToStr := 'сто';

2: CifrToStr := 'двести';

3: CifrToStr := 'триста';

4: CifrToStr := 'четыреста';

5: CifrToStr := 'пятьсот';

6: CifrToStr := 'шестьсот';

7: CifrToStr := 'семьсот';

8: CifrToStr := 'восемьсот';

9: CifrToStr := 'девятьсот';

0: CifrToStr := '';

end

elseif Pr = 2then

case i of

1: CifrToStr := '';

2: CifrToStr := 'двадцать';

3: CifrToStr := 'тридцать';

4: CifrToStr := 'сорок';

5: CifrToStr := 'пятьдесят';

6: CifrToStr := 'шестьдесят';

7: CifrToStr := 'семьдесят';

8: CifrToStr := 'восемьдесят';

9: CifrToStr := 'девяносто';

0: CifrToStr := '';

end

elseif Pr = 3then

case i of

1: if Padeg = 1then

CifrToStr := 'один'

else

CifrToStr := 'одна';

2: if Padeg = 1then

CifrToStr := 'два'

else

CifrToStr := 'две';

3: CifrToStr := 'три';

4: CifrToStr := 'четыре';

5: CifrToStr := 'пять';

6: CifrToStr := 'шесть';

7: CifrToStr := 'семь';

8: CifrToStr := 'восемь';

9: CifrToStr := 'девять';

0: CifrToStr := '';

end

elseif Pr = 4then

case i of

1: CifrToStr := 'одиннадцать';

2: CifrToStr := 'двенадцать';

3: CifrToStr := 'тринадцать';

4: CifrToStr := 'четырнадцать';

5: CifrToStr := 'пятнадцать';

6: CifrToStr := 'шестнадцать';

7: CifrToStr := 'семнадцать';

8: CifrToStr := 'восемнадцать';

9: CifrToStr := 'девятнадцать';

0: CifrToStr := 'десять';

end;

function Rasryad(K: Integer; V: string): string;

{Функция возвращает наименование разряда в зависимости от последних 2 цифр его}

var j: Integer;

begin

j := StrToInt(Copy(v, Length(v), 1));

if (StrToInt(Copy(v, Length(v) - 1, 2)) > 9) and (StrToInt(Copy(v, Length(v) - 1, 2)) < 20) then

case K of

0: Rasryad := '';

1: Rasryad := 'тысяч';

2: Rasryad := 'миллионов';

3: Rasryad := 'миллиардов';

4: Rasryad := 'триллионов';

end

else

case K of

0: Rasryad := '';

1: case j of

1: Rasryad := 'тысяча';

2..4: Rasryad := 'тысячи';

else

Rasryad := 'тысяч';

end;

2: case j of

1: Rasryad := 'миллион';

2..4: Rasryad := 'миллионa';

else

Rasryad := 'миллионов';

end;

3: case j of

1: Rasryad := 'миллиард';

2..4: Rasryad := 'миллиарда';

else

Rasryad := 'миллиардов';

end;

4: case j of

1: Rasryad := 'триллион';

2..4: Rasryad := 'триллиона';

else

Rasryad := 'триллионов';

end;

function GroupToStr(Group: string; Padeg: Integer): string;

{Функция возвращает прописью 3 цифры}

var i: Integer;

S: string;

begin

S := '';

if (StrToInt(Copy(Group, Length(Group) - 1, 2)) > 9) and (StrToInt(Copy(Group, Length(Group) - 1, 2)) < 20) then

begin

if Length(Group) = 3then

S := S + ' ' + CifrToStr(Copy(Group, 1, 1), 1, Padeg);

S := S + ' ' + CifrToStr(Copy(Group, Length(Group), 1), 4, Padeg);

end

else

for i := 1to Length(Group) do

S := S + ' ' + CifrToStr(Copy(Group, i, 1), i - Length(Group) + 3, Padeg);

GroupToStr := S;

end;

{Функция возвращает сумму прописью}

function RubToStr(Rubs: Currency; Rub, Kop: string): string;

var i, j: Integer;

R, K, S: string;

begin

S := CurrToStr(Rubs);

S := Trim(S);

if Pos(',', S) = 0then

begin

R := S;

K := '00';

end

else

begin

R := Copy(S, 0, (Pos(',', S) - 1));

K := Copy(S, (Pos(',', S) + 1), Length(S));

end;

S := '';

i := 0;

j := 1;

while Length(R) > 3do

begin

if i = 1then

j := 2

else

j := 1;

S := GroupToStr(Copy(R, Length(R) - 2, 3), j) + ' ' + Rasryad(i, Copy(R, Length(R) - 2, 3)) + ' ' + S;

R := Copy(R, 1, Length(R) - 3);

i := i + 1;

end;

if i = 1then

j := 2

else

j := 1;

S := Trim(GroupToStr(R, j) + ' ' + Rasryad(i, R) + ' ' + S + ' ' + Rub + ' ' + K + ' ' + Kop);

S := ANSIUpperCase(Copy(S, 1, 1)) + Copy(S, 2, Length(S) - 1);

RubToStr := S;

end;

Вот еще одно решение, присланное Олегом Клюкач.

Code:

unit Numinwrd;

interface

function sMoneyInWords(Nin: currency): string; export;

function szMoneyInWords(Nin: currency): PChar; export;

{ Денежная сумма Nin в рублях и копейках прописью

1997, в.2.1, by О.В.Болдырев}

implementation

uses SysUtils, Dialogs, Math;

type

tri = string[4];

mood = 1..2;

gender = (m, f);

uns = array[0..9] ofstring[7];

tns = array[0..9] ofstring[13];

decs = array[0..9] ofstring[12];

huns = array[0..9] ofstring[10];

nums = array[0..4] ofstring[8];

money = array[1..2] ofstring[5];

endings = array[gender, mood, 1..3] of tri; {окончания числительных и денег}

const

units: uns = ('', 'один ', 'два ', 'три ', 'четыре ', 'пять ',

'шесть ', 'семь ', 'восемь ', 'девять ');

unitsf: uns = ('', 'одна ', 'две ', 'три ', 'четыре ', 'пять ',

'шесть ', 'семь ', 'восемь ', 'девять ');

teens: tns = ('десять ', 'одиннадцать ', 'двенадцать ', 'тринадцать ',

'четырнадцать ', 'пятнадцать ', 'шестнадцать ',

'семнадцать ', 'восемнадцать ', 'девятнадцать ');

decades: decs = ('', 'десять ', 'двадцать ', 'тридцать ', 'сорок ',

'пятьдесят ', 'шестьдесят ', 'семьдесят ', 'восемьдесят ',

'девяносто ');

hundreds: huns = ('', 'сто ', 'двести ', 'триста ', 'четыреста ',

'пятьсот ', 'шестьсот ', 'семьсот ', 'восемьсот ',

'девятьсот ');

numericals: nums = ('', 'тысяч', 'миллион', 'миллиард', 'триллион');

RusMon: money = ('рубл', 'копе');

ends: endings = ((('', 'а', 'ов'), ('ь', 'я', 'ей')),

(('а', 'и', ''), ('йка', 'йки', 'ек')));

threadvar

str: string;

function EndingIndex(Arg: integer): integer;

begin

if ((Arg div10) mod10) <> 1then

case (Arg mod10) of

1: Result := 1;

2..4: Result := 2;

else

Result := 3;

end

else

Result := 3;

end;

function sMoneyInWords(Nin: currency): string; { Число Nin прописью, как функция }

var

// str: string;

g: gender; //род

Nr: comp; {целая часть числа}

Fr: integer; {дробная часть числа}

i, iTri, Order: longint; {триада}

procedure Triad;

var

iTri2: integer;

un, de, ce: byte; //единицы, десятки, сотни

function GetDigit: byte;

begin

Result := iTri2 mod10;

iTri2 := iTri2 div10;

end;

begin

iTri := trunc(Nr / IntPower(1000, i));

Nr := Nr - int(iTri * IntPower(1000, i));

iTri2 := iTri;

if iTri > 0then

begin

un := GetDigit;

de := GetDigit;

ce := GetDigit;

if i = 1then

g := f

else

g := m; {женского рода только тысяча}

str := TrimRight(str) + ' ' + Hundreds[ce];

if de = 1then

str := TrimRight(str) + ' ' + Teens[un]

else

begin

str := TrimRight(str) + ' ' + Decades[de];

case g of

m: str := TrimRight(str) + ' ' + Units[un];

f: str := TrimRight(str) + ' ' + UnitsF[un];

end;

if length(numericals[i]) > 1then

begin

str := TrimRight(str) + ' ' + numericals[i];

str := TrimRight(str) + ends[g, 1, EndingIndex(iTri)];

end;

end; //triad is 0 ?

if i = 0then Exit;

Dec(i);

Triad;

end;

begin

str := '';

Nr := int(Nin);

Fr := round(Nin * 100 + 0.00000001) mod100;

if Nr > 0then

Order := trunc(Log10(Nr) / 3)

else

begin

str := 'ноль';

Order := 0

end;

if Order > High(numericals) then

raise Exception.Create('Слишком большое число для суммы прописью');

i := Order;

Triad;

str :=

Format('%s %s%s %.2d %s%s', [Trim(str), RusMon[1], ends[m, 2, EndingIndex(iTri)],

Fr, RusMon[2], ends[f, 2, EndingIndex(Fr)]]);

str[1] := (ANSIUpperCase(copy(str, 1, 1)))[1];

str[Length(str) + 1] := #0;

Result := str;

end;

function szMoneyInWords(Nin: currency): PChar;

begin

sMoneyInWords(Nin);

Result := @(str[1]);

end;

end.

Взято из Советов по Delphi от Валентина Озерова

Сборник Kuliba

Code:

unit FullSum;

interface

uses SysUtils;

{

Функция перевода суммы, записанной цифрами в сумму прописью :

например, 23.12 -> двадцать три рубля 12 копеек.

переводит до 999999999 руб. 99 коп.

Функция не отслеживает, правильное ли значение получено в параметре Number

(т.е. положительное и округленное с точностью до сотых) - эту проверку

необходимо провести до вызова функции.

}

//----------------- mailto: egor vladi.elektra

function SumNumToFull(Number: real): string;

implementation

function SumNumToFull(Number:real):string;

var

PartNum, TruncNum, NumTMP, D: integer;

NumStr : string;

i, R : byte;

Flag11 : boolean;

begin

D:=1000000;

R:=4;

//выделяем рубли

TruncNum:=Trunc(Number);

if TruncNum<>0then

repeat

PartNum:=TruncNum div D;

Dec(R);

D:=D div1000;

until

PartNum<>0

else

R:=0;

// перевод рублей

for i:=R downto1do

begin

Flag11:=False;

// выделение цифры сотен

NumTMP:=PartNum div100;

case NumTMP of

1: NumStr:=NumStr+'сто ';

2: NumStr:=NumStr+'двести ';

3: NumStr:=NumStr+'триста ';

4: NumStr:=NumStr+'четыреста ';

5: NumStr:=NumStr+'пятьсот ';

6: NumStr:=NumStr+'шестьсот ';

7: NumStr:=NumStr+'семьсот ';

8: NumStr:=NumStr+'восемьсот ';

9: NumStr:=NumStr+'девятьсот ';

end;

// выделение цифры десятков

NumTMP:=(PartNum mod100) div10;

case NumTMP of

begin

NumTMP:=PartNum mod100;

case NumTMP of

10: NumStr:=NumStr+'десять ';

11: NumStr:=NumStr+'одиннадцать ';

12: NumStr:=NumStr+'двенадцать ';

13: NumStr:=NumStr+'тринадцать ';

14: NumStr:=NumStr+'четырнадцать ';

15: NumStr:=NumStr+'пятнадцать ';

16: NumStr:=NumStr+'шестнадцать ';

17: NumStr:=NumStr+'семнадцать ';

18: NumStr:=NumStr+'восемнадцать ';

19: NumStr:=NumStr+'девятнадцать ';

end;

case i of

3: NumStr:=NumStr+'миллионов ';

2: NumStr:=NumStr+'тысяч ';

1: NumStr:=NumStr+'рублей ';

end;

Flag11:=True;

end;

2: NumStr:=NumStr+'двадцать ';

3: NumStr:=NumStr+'тридцать ';

4: NumStr:=NumStr+'сорок ';

5: NumStr:=NumStr+'пятьдесят ';

6: NumStr:=NumStr+'шестьдесят ';

7: NumStr:=NumStr+'семьдесят ';

8: NumStr:=NumStr+'восемьдесят ';

9: NumStr:=NumStr+'девяносто ';

end;

// выделение цифры единиц

NumTMP:=PartNum mod10;

ifnot Flag11 then

begin

case NumTMP of

if i=2then

NumStr:=NumStr+'одна '

else

NumStr:=NumStr+'один ';

if i=2then

NumStr:=NumStr+'две '

else

NumStr:=NumStr+'два ';

3: NumStr:=NumStr+'три ';

4: NumStr:=NumStr+'четыре ';

5: NumStr:=NumStr+'пять ';

6: NumStr:=NumStr+'шесть ';

7: NumStr:=NumStr+'семь ';

8: NumStr:=NumStr+'восемь ';

9: NumStr:=NumStr+'девять ';

end;

case i of

case NumTMP of

1: NumStr:=NumStr+'миллион ';

2,3,4: NumStr:=NumStr+'миллиона ';

else

NumStr:=NumStr+'миллионов ';

end;

case NumTMP of

1 : NumStr:=NumStr+'тысяча ';

2,3,4: NumStr:=NumStr+'тысячи ';

else

if PartNum<>0then

NumStr:=NumStr+'тысяч ';

end;

case NumTMP of

1 : NumStr:=NumStr+'рубль ';

2,3,4: NumStr:=NumStr+'рубля ';

else

NumStr:=NumStr+'рублей ';

end;

if i>1then

begin

PartNum:=(TruncNum mod (D*1000)) div D;

D:=D div1000;

end;

//перевод копеек

PartNum:=Round(Frac(Number)*100);

if PartNum=0then

begin

SumNumToFull:=NumStr+'00 копеек';

Exit;

end;

// выделение цифры десятков

NumTMP:=PartNum div10;

if NumTMP=0then

NumStr:=NumStr+'0'+IntToStr(PartNum)+' '

else

NumStr:=NumStr+IntToStr(PartNum)+' ';

// выделение цифры единиц

NumTMP:=PartNum mod10;

case NumTMP of

if PartNum<>11then

NumStr:=NumStr+'копейка'

else

NumStr:=NumStr+'копеек';

2,3,4:

if (PartNum<5) or (PartNum>14) then

NumStr:=NumStr+'копейки'

else

NumStr:=NumStr+'копеек';

else

NumStr:=NumStr+'копеек';

end;

SumNumToFull:=NumStr;

end;

end.

https://delphiworld.narod

DelphiWorld 6.0

Code:

{ Преобразует трехзначное число в строку }

function ConvertToWord(N: word): string;

const

Sot : array[1..9] ofstring[13] =

('сто','двести','триста','четыреста','пятьсот',

'шестьсот','семьсот','восемьсот','девятьсот');

Des : array[2..9] ofstring[13] =

('двадцать','тридцать','сорок','пятьдесят',

'шестьдесят','семьдесят','восемьдесят','девяносто');

Edin : array[0..19] ofstring[13] =

('','один','два','три','четыре','пять','шесть','семь',

'восемь','девять','десять','одиннадцать','двенадцать',

'тринадцать','четырнадцать','пятнадцать',

'шестнадцать','семнадцать','восемнадцать','девятнадцать');

var

S: string;

begin

S:='';

N:=N mod1000;

if N>99then

begin

S:=Sot[N div100]+' ';

N:=N mod100;

end;

if N>19then

begin

S:=S+Des[N div10]+' ';

N:=N mod10;

end;

Result:=S+Edin[N];

end;

{ Возвращает сумму прописью }

function CenaToStr(r: Currency): string;

var

N, k: longint;

S: string;

begin

N:=trunc(R); S:='';

if N<>0then

begin

if N>999999then

begin

k:=N div1000000;

S:=ConvertToWord(k);

if ((k-(k div100)*100)>10) and ((k-(k div100)*100)<20) then

S:=S+' миллионов'

else

if (k mod10)=1then

S:=S+' миллион'

else

if ((k mod10)>=2)and((k mod10)<=4) then

S:=S+' миллиона'

else

S:=S+' миллионов';

N:=N mod1000000;

end;

if N>999then

begin

k:=N div1000;

S:=S+' '+ConvertToWord(k);

if ((k-(k div100)*100)>10)and((k-(k div100)*100)<20) then

S:=S+' тысяч'

else

if (k mod10)=1then

begin

SetLength(S, Length(S)-2);

S:=S+'на тысяча';

end

else

if (k mod10)=2then

begin

SetLength(S, length(S)-1);

S:=S+'е тысячи';

end

else

if ((k mod10)>=3)and((k mod10)<=4) then

S:=S+' тысячи'

else

S:=S+' тысяч';

N:=N mod1000;

end;

k:=N;

S:=S+' '+ConvertToWord(k);

if ((k-(k div100)*100)>10)and((k-(k div100)*100)<20) then

S:=S+' рублей'

else

if (k mod10)=1then

S:=S+' рубль'

else

if (k mod10)=2then

S:=S+' рубля'

else

if ((k mod10)>=3)and((k mod10)<=4) then

S:=S+' рубля'

else

S:=S+' рублей';

end;

if trunc(R)<>R then

begin

k:=round(frac(R)*100);

S:=S+' '+IntToStr(K);

if ((k-(k div100)*100)>10)and((k-(k div100)*100)<20) then

S:=S+' копеек'

else

if (k mod10)=1then

begin

S:=S+' копейка';

end

else

if (k mod10)=2then

begin

S:=S+' копейки';

end

else

if ((k mod10)>=3)and((k mod10)<=4) then

S:=S+' копейки'

else

S:=S+' копеек';

end

else

S:=S+' 00 копеек';

S:=Trim(S);

if S<>''then

S[1]:=AnsiUpperCase(S[1])[1];

result:=S;

end;

https://delphiworld.narod

DelphiWorld 6.0

Code:

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

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

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

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

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

Зависимости: SysUtils

Автор: fnatali, fnatali yandex.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;

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;

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

...

https://delphiworld.narod

DelphiWorld 6.0

Code:

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

>> Преобразование целого числа 0-999999999 в строку (прописью)

Я думаю, всё итак понятно, что не понятно пишите письма

Зависимости: SysUtils

Автор: Алексей, ARojkov okil.ru, СПб

Дата: 12 марта 2004 г.

***************************************************** }

unit UIntToStroka;

interface

uses SysUtils;

const

N1: array[0..9] ofstring = ('ноль',

'один',

'два',

'три',

'четыре',

'пять',

'шесть',

'семь',

'восемь',

'девять');

const

N1000: array[1..9] ofstring = ('одна',

'две',

'три',

'четыре',

'пять',

'шесть',

'семь',

'восемь',

'девять');

const

N11: array[0..9] ofstring = ('десять',

'одиннадцать',

'двенадцать',

'тринадцать',

'четырнадцать',

'пятнадцать',

'шестнадцать',

'семнадцать',

'восемнадцать',

'девятнадцать');

const

N2: array[1..9] ofstring = ('десять',

'двадцать',

'тридцать',

'сорок',

'пятьдесят',

'шестьдесят',

'семьдесят',

'восемьдесят',

'девяносто'

);

const

N3: array[1..9] ofstring = ('сто',

'двести',

'триста',

'четыреста',

'пятьсот',

'шестьсот',

'семьсот',

'восемьсот',

'девятьсот'

);

const

NThousand: array[1..3] ofstring = ('тысяча ',

'тысячи ',

'тысяч ');

const

NMillion: array[1..3] ofstring = ('миллион ',

'миллиона ',

'миллионов ');

function IntToStroka(n: Integer): AnsiString;

implementation

function IntToStroka(n: Integer): AnsiString;

var

i, j, dec, j0: Integer;

s: string;

degt, degm: boolean;

buf: string;

begin

degt := false;

degm := false;

s := IntToStr(n);

Result := '';

for i := length(s) downto1do

begin

dec := (length(s) - i + 1); // получим разряд

j := StrToInt(s[i]); // получим цифру

if j = 0then

j0 := 0;

if (not (j in [1..9])) and (dec <> 1) then

Continue;

if Dec in [1, 4, 7, 10] then

try

if StrToInt(s[i - 1]) = 1then

begin

j0 := j;

Continue;

end; // подготовка к 10..19 тысяч/миллионов

except

end;

if Dec in [2, 5, 8, 11] then

if j = 1then

begin

case dec of

2: Result := N11[j0] + ' '; // если 10..19 тысяч/миллионов

begin

Result := N11[j0] + ' ' + NThousand[3] + Result;

degt := true;

end;

begin

Result := N11[j0] + ' ' + NMillion[3] + Result;

degm := true;

end;

Continue;

end;

if DEC in [4..6] then

begin

if (j <> 0) and (not degt) then

begin

if dec = 4then

case j of

1: buf := NThousand[1];

2..4: buf := NThousand[2];

// прибавим слово тысяча если ещё не добавляли

5..9: buf := NThousand[3];

end

else

buf := NThousand[3];

degt := true;

end;

if DEC in [7..9] then

begin

if (j <> 0) and (not degm) then

begin

if dec = 7then

case j of

1: buf := NMillion[1];

2..4: buf := NMillion[2];

// прибавим слово миллион если ещё не добавляли

5..9: buf := NMillion[3];

end

else

buf := NMillion[3];

degm := true;

end;

Result := buf + Result;

while dec > 3do

dec := dec - 3;

case Dec of

1: if j <> 0then

if degt and (not degm) then

Result := N1000[j] + ' ' + Result

else

Result := N1[j] + ' ' + Result; // 3 три

2: Result := N2[j] + ' ' + Result; // 23 двадцать три

3: Result := N3[j] + ' ' + Result; // 123 сто двадцать три

end;

Buf := '';

j0 := j;

end;

end.

Code:

function NumToStr(n: double; c: byte = 0): string;

c=0 - 21.05 -> 'Двадцать один рубль 05 копеек.'

с=1 - 21.05 -> 'двадцать один'

c=2 - 21.05 -> '21-05', 21.00 -> '21='

const

digit: array[0..9] ofstring = ('ноль', 'оди', 'два', 'три', 'четыр',

'пят', 'шест', 'сем', 'восем', 'девят');

var

ts, mln, mlrd, SecDes: Boolean;

len: byte;

summa: string;

function NumberString(number: string): string;

var

d, pos: byte;

function DigitToStr: string;

begin

result := '';

if (d <> 0) and ((pos = 11) or (pos = 12)) then

mlrd := true;

if (d <> 0) and ((pos = 8) or (pos = 9)) then

mln := true;

if (d <> 0) and ((pos = 5) or (pos = 6)) then

ts := true;

if SecDes then

begin

case d of

0: result := 'десять ';

2: result := 'двенадцать '

else

result := digit[d] + 'надцать '

end;

case pos of

4: result := result + 'тысяч ';

7: result := result + 'миллионов ';

10: result := result + 'миллиардов '

end;

SecDes := false;

mln := false;

mlrd := false;

ts := false

end

else

begin

if (pos = 2) or (pos = 5) or (pos = 8) or (pos = 11) then

case d of

1: SecDes := true;

2, 3: result := digit[d] + 'дцать ';

4: result := 'сорок ';

9: result := 'девяносто ';

5..8: result := digit[d] + 'ьдесят '

end;

if (pos = 3) or (pos = 6) or (pos = 9) or (pos = 12) then

case d of

1: result := 'сто ';

2: result := 'двести ';

3: result := 'триста ';

4: result := 'четыреста ';

5..9: result := digit[d] + 'ьсот '

end;

if (pos = 1) or (pos = 4) or (pos = 7) or (pos = 10) then

case d of

1: result := 'один ';

2, 3: result := digit[d] + ' ';

4: result := 'четыре ';

5..9: result := digit[d] + 'ь '

end;

if pos = 4then

begin

case d of

0: if ts then

result := 'тысяч ';

1: result := 'одна тысяча ';

2: result := 'две тысячи ';

3, 4: result := result + 'тысячи ';

5..9: result := result + 'тысяч '

end;

ts := false

end;

if pos = 7then

begin

case d of

0: if mln then

result := 'миллионов ';

1: result := result + 'миллион ';

2, 3, 4: result := result + 'миллиона ';

5..9: result := result + 'миллионов '

end;

mln := false

end;

if pos = 10then

begin

case d of

0: if mlrd then

result := 'миллиардов ';

1: result := result + 'миллиард ';

2, 3, 4: result := result + 'миллиарда ';

5..9: result := result + 'миллиардов '

end;

mlrd := false

end

end;

begin

result := '';

ts := false;

mln := false;

mlrd := false;

SecDes := false;

len := length(number);

if (len = 0) or (number = '0') then

result := digit[0]

else

for pos := len downto1do

begin

d := StrToInt(copy(number, len - pos + 1, 1));

result := result + DigitToStr

end

end;

function MoneyString(number: string): string;

var

s: string[1];

n: string;

begin

len := length(number);

n := copy(number, 1, len - 3);

result := NumberString(n);

s := AnsiUpperCase(result[1]);

delete(result, 1, 1);

result := s + result;

if len < 2then

begin

if len = 0then

n := '0';

len := 2;

n := '0' + n

end;

if copy(n, len - 1, 1) = '1'then

result := result + 'рублей'

else

begin

case StrToInt(copy(n, len, 1)) of

1: result := result + 'рубль';

2, 3, 4: result := result + 'рубля'

else

result := result + 'рублей'

end

end;

len := length(number);

n := copy(number, len - 1, len);

if copy(n, 1, 1) = '1'then

n := n + ' копеек.'

else

begin

case StrToInt(copy(n, 2, 1)) of

1: n := n + ' копейка.';

2, 3, 4: n := n + ' копейки.'

else

n := n + ' копеек.'

end

end;

result := result + ' ' + n

end;

// Основная часть

begin

case c of

0: result := MoneyString(FormatFloat('0.00', n));

1: result := NumberString(FormatFloat('0', n));

begin

summa := FormatFloat('0.00', n);

len := length(summa);

if copy(summa, len - 1, 2) = '00'then

begin

delete(summa, len - 2, 3);

result := summa + '='

end

else

begin

delete(summa, len - 2, 1);

insert('-', summa, len - 2);

result := summa;

end;

end

end;

https://delphiworld.narod

DelphiWorld 6.0

Честно, давно ждал подобного журнала в электронном виде. Решил послать своё творчество которое уже немало отработало, опять же, преобразование числа в пропись, отличающееся от опубликованных программок тем, что слова для прописи хранятся в отдельном файле (lang.cnf), по аналогии с подуктами 1C. Это позволяет изменять национальную валюту.

Если поэкспериментировать, с массивом Univer, в котором хранятся окончания, можно добиться преобразования для многих языков, не сказал ли я чего лишнего. :)

Надеюсь, моя версия Вам понравится.

С наилучшими пожеланиями,

Панченко Сергей

Казахстан, Алматы,

Code:

unit BuchUtil;

interface

uses IniFiles, SysUtils;

function DoubleChar(ch: string): string;

function NumToSampl(N: string): string;

function MoneyToSampl(M: Currency): string;

procedure LexemsToDim(fstr: string; var dim: arrayofstring);

var

NameNum: array[0..9, 1..4] ofstring; //массив им?н чисел

Ext: array[0..4, 1..3] ofstring; //массив расшиений (тысячи, миллионы ...)

Univer: array[1..9, 1..4] of integer; //массив окончаний

Rubl: array[1..3] ofstring; //массив имен рублей

Cop: array[1..3] ofstring; //массив имен копеек

Zero: string; //название нуля

One: string; //единица "одна"

Two: string; //двойка "две"

fFile: TIniFile; //файл, откуда загружается пропись

fString: string;

fDim: array[0..9] ofstring;

i: integer;

implementation

{заполняет массив Dim лексемами}

procedure LexemsToDim(fstr: string; var dim: arrayofstring);

var

i, j: integer;

flex: string;

begin

if Length(fstr) > 0then

begin

i := 1;

j := 0;

while i - 1 < Length(fstr) do

begin

if fstr[i] = ','then

begin

dim[j] := flex + ' ';

inc(j);

flex := '';

end

else

flex := flex + fstr[i];

inc(i);

end;

{преобразует число в пропись

процедура использует файл lang.cnf}

function NumToSampl(N: string): string;

var

k, i, i_indx: integer;

number, string_num: string;

index: integer;

pos: integer;

fl_ext: boolean;

begin

fl_ext := true;

i := 1;

String_num := '';

number := Trim(N);

k := length(number);

if (k = 1) and (number = '0') then

String_num := Zero

else

begin

pos := 0;

while (k > 0) do

begin

if (k <> 1) and (i = 1) and (length(number) <> 1) and (copy(number, k - 1,

1) = '1')

and (copy(number, k, 1) <> '0') then

begin

index := StrToInt(copy(number, k, 1));

dec(k);

inc(i);

i_indx := 4;

end

else

begin

index := StrToInt(copy(number, k, 1));

i_indx := i;

end;

if (NameNum[index, i_indx] <> '') and (fl_ext = true) then

begin

String_num := Ext[pos, Univer[index, i_indx]] + String_num;

fl_ext := false;

end;

if (index = 1) and (pos = 1) and (i = 1) then

String_num := One + String_num

elseif (index = 2) and (pos = 1) and (i = 1) then

String_num := Two + String_num

else

String_num := NameNum[index, i_indx] + String_num;

inc(i);

if i = 4then

begin

i := 1;

inc(pos);

fl_ext := true

end;

dec(k);

end;

if Trim(String_Num) <> ''then

begin

String_num[1] := CHR(ORD(String_num[1]) - 32);

Result := String_num;

end;

{Преобразует х в 0х}

function DoubleChar(ch: string): string;

begin

if Length(ch) = 1then

Result := '0' + ch

else

Result := ch;

end;

{преобразует денежную сумму в пропись}

function MoneyToSampl(M: Currency): string;

var

Int_Part, idx, idxIP, idxRP: integer;

Int_Str, Real_Part, Sampl: string;

begin

Int_Part := Trunc(Int(M));

Int_Str := IntToStr(Int_Part);

Real_Part := DoubleChar(IntToStr(Trunc(Int((M - Int_Part + 0.001) * 100))));

Sampl := NumToSampl(Int_Str);

idx := StrToInt(Int_Str[Length(Int_Str)]);

if idx = 0then

idx := 5;

idxIP := Univer[idx, 1];

idx := StrToInt(Real_Part[Length(Real_Part)]);

if idx = 0then

idx := 5;

idxRP := Univer[idx, 1];

Result := Sampl + Rubl[idxIP] + Real_Part + ' ' + Cop[idxRP];

end;

initialization

{Предположим файл находится на C:\ диске}

fFile := TIniFile.Create('c:\lang.cnf');

try

{Заполнение массива рублей}

fString := fFile.ReadString('Money', 'Rub', ',');

LexemsToDim(fString, Rubl);

{Заполнение массива копеек}

fString := fFile.ReadString('Money', 'Cop', ',');

LexemsToDim(fString, Cop);

{Заполнение массива чисел}

fString := fFile.ReadString('Nums', 'Numbers', ',');

LexemsToDim(fString, fdim);

NameNum[0, 1] := '';

for i := 1to9do

NameNum[i, 1] := fdim[i - 1];

{Заполнение массива десятков}

fString := fFile.ReadString('Nums', 'Tens', ',');

LexemsToDim(fString, fdim);

NameNum[0, 2] := '';

for i := 1to9do

NameNum[i, 2] := fdim[i - 1];

{Заполнение массива сотен}

fString := fFile.ReadString('Nums', 'Hundreds', ',');

LexemsToDim(fString, fdim);

NameNum[0, 3] := '';

for i := 1to9do

NameNum[i, 3] := fdim[i - 1];

{Заполнение массива чисел после десяти}

fString := fFile.ReadString('Nums', 'AfterTen', ',');

LexemsToDim(fString, fdim);

NameNum[0, 4] := '';

for i := 1to9do

NameNum[i, 4] := fdim[i - 1];

{Заполнение расширений чисел}

Ext[0, 1] := '';

Ext[0, 2] := '';

Ext[0, 3] := '';

{Тысячи}

fString := fFile.ReadString('Nums', 'Thou', ',');

LexemsToDim(fString, fdim);

for i := 1to3do

Ext[1, i] := fdim[i - 1];

{Миллионы}

fString := fFile.ReadString('Nums', 'Mill', ',');

LexemsToDim(fString, fdim);

for i := 1to3do

Ext[2, i] := fdim[i - 1];

{Миллиарды}

fString := fFile.ReadString('Nums', 'Bill', ',');

LexemsToDim(fString, fdim);

for i := 1to3do

Ext[3, i] := fdim[i - 1];

{Триллион}

fString := fFile.ReadString('Nums', 'Thrill', ',');

LexemsToDim(fString, fdim);

for i := 1to3do

Ext[4, i] := fdim[i - 1];

Zero := fFile.ReadString('Nums', 'Zero', '0');

if Zero[Length(Zero)] = ','then

Zero := Copy(Zero, 1, Length(Zero) - 1) + ' ';

One := fFile.ReadString('Nums', 'One', '1');

if One[Length(One)] = ','then

One := Copy(One, 1, Length(One) - 1) + ' ';

Two := fFile.ReadString('Nums', 'Two', '0');

if Two[Length(Two)] = ','then

Two := Copy(Two, 1, Length(Two) - 1) + ' ';

{Заполнение таблицы окончаний}

Univer[1, 1] := 1;

Univer[1, 2] := 2;

Univer[1, 3] := 2;

Univer[1, 4] := 2;

Univer[2, 1] := 3;

Univer[2, 2] := 2;

Univer[2, 3] := 2;

Univer[2, 4] := 2;

Univer[3, 1] := 3;

Univer[3, 2] := 2;

Univer[3, 3] := 2;

Univer[3, 4] := 2;

Univer[4, 1] := 3;

Univer[4, 2] := 2;

Univer[4, 3] := 2;

Univer[4, 4] := 2;

Univer[5, 1] := 2;

Univer[5, 2] := 2;

Univer[5, 3] := 2;

Univer[5, 4] := 2;

Univer[6, 1] := 2;

Univer[6, 2] := 2;

Univer[6, 3] := 2;

Univer[6, 4] := 2;

Univer[7, 1] := 2;

Univer[7, 2] := 2;

Univer[7, 3] := 2;

Univer[7, 4] := 2;

Univer[8, 1] := 2;

Univer[8, 2] := 2;

Univer[8, 3] := 2;

Univer[8, 4] := 2;

Univer[9, 1] := 2;

Univer[9, 2] := 2;

Univer[9, 3] := 2;

Univer[9, 4] := 2;

finally

fFile.Free;

end;

end.

Code:Lang.cnf

[Nums]

Numbers=один,два,три,четыре,пять,шесть,семь,восемь,девять,

One=одна,

Two=две,

Tens=десять,двадцать,тридцать,сорок,пятьдесят,шестьдесят,семьдесят,восемьдесят,девяносто,

Hundreds=сто,двести,триста,четыреста,пятьсот,шестьсот,семьсот,восемьсот,девятьсот,

AfterTen=одиннадцать,двенадцать,тринадцать,четырнадцать,пятнадцать,шестнадцать,семнадцать,восемнадцать,девятнадцать,

Zero=ноль,

Thou=тысяча,тысяч,тысячи,

Mill=миллион,миллионов,миллиона,

Bill=миллиард,миллиардов,миллиарда,

Thrill=триллион,триллионов,триллиона,

[Money]

Rub=рубль,рублей,рубля,

Cop=копейка,копеек,копейки,

https://delphiworld.narod

DelphiWorld 6.0

Code:

unit sumstr;

interface

uses

SysUtils, StrUtils;

function SumToString(Value: string): string;

implementation

const

a: array[0..8,0..9] ofstring=(

('','один ','два ','три ','четыре ','пять ','шесть ','семь ','восемь ','девять '),

('','','двадцать ','тридцать ','сорок ','пятьдесят ','шестьдесят ','семьдесят ','восемьдесят ','девяносто '),

('','сто ','двести ','триста ','четыреста ','пятьсот ','шестьсот ','семьсот ','восемьсот ','девятьсот '),

('тысяч ','тысяча ','две тысячи ','три тысячи ','четыре тысячи ','пять тысячь ','шесть тысячь ','семь тысячь ',

'восемь тысячь ','девять тысячь '),

('','','двадцать ','тридцать ','сорок ','пятьдесят ','шестьдесят ','семьдесят ','восемьдесят ','девяносто '),

('','сто ','двести ','триста ','четыреста ','пятьсот ','шестьсот ','семьсот ','восемьсот ','девятьсот '),

('миллионов ','один миллион ','два миллиона ','три миллиона ','четыре миллиона ','пять миллионов ',

'шесть миллионов ','семь миллионов ','восемь миллионов ','девять миллионов '),

('','','двадцать ','тридцать ','сорок ','пятьдесят ','шестьдесят ','семьдесят ','восемьдесят ','девяносто '),

('','сто ','двести ','триста ','четыреста ','пятьсот ','шестьсот ','семьсот ','восемьсот ','девятьсот '));

b: array[0..9] ofstring=

('десять ','одинадцать ','двенадцать ','тринадцать ','четырнадцать ','пятьнадцать ','шестьнадцать ',

'семьнадцать ','восемьнадцать ','девятьнадцать ');

function SumToStrin(Value: string): string;

var

s, t: string;

p, pp, i, k: integer;

begin

s:=value;

if s='0'then

t:='Ноль '

else

begin

p:=length(s);

pp:=p;

if p>1then

if (s[p-1]='1') and (s[p]>'0') then

begin

t:=b[strtoint(s[p])];

pp:=pp-2;

end;

i:=pp;

while i>0do

begin

if (i=p-3) and (p>4) then

if s[p-4]='1'then

begin

t:=b[strtoint(s[p-3])]+'тысяч '+t;

i:=i-2;

end;

if (i=p-6) and (p>7) then

if s[p-7]='1'then

begin

t:=b[strtoint(s[p-6])]+'миллионов '+t;

i:=i-2;

end;

if i>0then

begin

k:=strtoint(s[i]);

t:=a[p-i,k]+t;

i:=i-1;

end;

result:=t;

end;

procedure get2str(value: string; var hi, lo: string);

var

p: integer;

begin

p:=pos(',', value);

lo:='';

hi:='';

if p=0then

p:=pos('.', value);

if p<>0then

delete(value,p,1);

if p=0then

begin

hi:=value;

lo:='00';

end;

if p>length(value) then

begin

hi:=value;

lo:='00';

end;

if p=1then

begin

hi:='0';

lo:=value;

end;

if (p>1) and (p then

begin

hi:=copy(value,1,p-1);

lo:=copy(value,p,length(value));

end;

function sumtostring(value: string): string;

var

hi, lo: string;

pr, er: integer;

begin

get2str(value,hi,lo);

if (hi='') or (lo='') then

begin

result:='';

exit;

end;

val(hi,pr,er);

if er<>0then

begin

result:='';

exit;

end;

hi:=sumtostrin(inttostr(pr))+'руб. ';

if lo<>'00'then

begin

val(lo,pr,er);

if er<>0then

begin

result:='';

exit;

end;

lo:=inttostr(pr);

end;

lo:=lo+' коп. ';

hi[1]:=AnsiUpperCase(hi[1])[1];

result:=hi+lo;

end;

end.

https://delphiworld.narod

DelphiWorld 6.0

Этот алгоритм преобразует 12345 в "двенадцать тысяч триста сорок пять". Для этого создана процедура, которая преобразует трехзначные числа в слова и прибавляет к ним "тысяч" или "миллионов". Алгоритм корректен в смысле падежей и родов. Поэтому 121000 он не переведет в "сто двадцать один тысяч".

Code:

function ShortNum(num: word; razr: integer): string;

const

hundreds: array [0..9] ofstring =

('', ' сто', ' двести', ' триста',

' четыреста', ' пятьсот', ' шестьсот', ' семьсот', ' восемьсот',

' девятьсот');

tens: array [0..9] ofstring =

('', '', ' двадцать', ' тридцать',

' сорок', ' пятьдесят', ' шестьдесят', ' семьдесят', ' восемьдесят',

' девяносто');

ones: array [3..19] ofstring =

(' три', ' четыре', ' пять', ' шесть',

' семь', ' восемь', ' девять', ' десять', ' одиннадцать',

' двенадцать', ' тринадцать', ' четырнадцать', ' пятнадцать',

' шестнадцать', ' семнадцать', ' восемнадцать', ' девятнадцать');

razryad: array [0..6] ofstring =

('', ' тысяч', ' миллион', ' миллиард',

' триллион', ' квадриллион', ' квинтиллион');

var

t: byte; // десятки

o: byte; // единицы

begin

result := hundreds[num div100];

if num = 0then

Exit;

t := (num mod100) div10;

o := num mod10;

if t <> 1then

begin

result := result + tens[t];

case o of

if razr = 1then

result := result + ' одна'

else

result := result + ' один';

if razr = 1then

result := result + ' две'

else

result := result + ' два';

3..9:

result := result + ones[o];

end;

result := result + razryad[razr];

case o of

if razr = 1then

result := result + 'а';

2..4:

if razr = 1then

result := result + 'и'

else

if razr > 1then

result := result + 'а';

else

if razr > 1then

result := result + 'ов';

end;

end

else

begin

result := result + ones[num mod100];

result := result + razryad[razr];

if razr > 1then

result := result + 'ов';

end;

function IntToWords(s: string): string;

var

i, count: integer;

begin

if (Length(s) <= 0) or (s = '0') then

begin

result := 'ноль';

Exit;

end;

count := (Length(s) + 2) div3;

if count > 7then

begin

result := 'Value is too large';

Exit;

end;

result := '';

s := '00' + s;

for i := 1to count do

result := ShortNum(StrToInt(copy(s, Length(s) - 3 * i + 1, 3)),

i - 1) + result;

if Length(result) > 0then

delete(result, 1, 1);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

Edit2.Text := IntToWords(Edit1.Text);

end;

https://delphiworld.narod.

DelphiWorld 6.0

Code:

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

>> Сумма и количество прописью, работа с падежами

Несколько функций для работы с строками:

function SumToString(Value : String) : string;//Сумма прописью

function KolToStrin(Value : String) : string;//Количество прописью

function padeg(s:string):string;//Склоняет фамилию имя и отчество (кому)

function padegot(s:string):string;//Склоняет фамилию имя и отчество (от кого)

function fio(s:string):string;//фамилия имя и отчество сокращенно

function longdate(s:string):string;//Длинная дата

procedure getfullfio(s:string;var fnam,lnam,onam:string);

//Получить из строки фамилию имя и отчество сокращенно

Зависимости: uses SysUtils, StrUtils,Classes;

Автор: Eda, eda arhadm.net.ru, Архангельск

Дата: 13 июня 20013 г.

***************************************************** }

unit sumstr;

interface

uses

SysUtils, StrUtils, Classes;

var

rub: byte;

function SumToString(Value: string): string; //Сумма прописью

function KolToStrin(Value: string): string; //Количество прописью

function padeg(s: string): string; //Склоняет фамилию имя и отчество (кому)

function padegot(s: string): string; //Склоняет фамилию имя и отчество (от кого)

function fio(s: string): string; //фамилия имя и отчество сокращенно

function longdate(s: string): string; //Длинная дата

procedure getfullfio(s: string; var fnam, lnam, onam: string);

//Получить из строки фамилию имя и отчество сокращенно

implementation

const

a: array[0..8, 0..9] ofstring = (

('', 'один ', 'два ', 'три ', 'четыре ', 'пять ', 'шесть ', 'семь ',

'восемь ', 'девять '),

('', '', 'двадцать ', 'тридцать ', 'сорок ', 'пятьдесят ', 'шестьдесят ',

'семьдесят ', 'восемьдесят ', 'девяносто '),

('', 'сто ', 'двести ', 'триста ', 'четыреста ', 'пятьсот ', 'шестьсот ',

'семьсот ', 'восемьсот ', 'девятьсот '),

('тысяч ', 'одна тысяча ', 'две тысячи ', 'три тысячи ', 'четыре тысячи ',

'пять тысяч ', 'шесть тысяч ', 'семь тысяч ', 'восемь тысяч ',

'девять тысяч '),

('', '', 'двадцать ', 'тридцать ', 'сорок ', 'пятьдесят ', 'шестьдесят ',

'семьдесят ', 'восемьдесят ', 'девяносто '),

('', 'сто ', 'двести ', 'триста ', 'четыреста ', 'пятьсот ', 'шестьсот ',

'семьсот ', 'восемьсот ', 'девятьсот '),

('миллионов ', 'один миллион ', 'два миллиона ', 'три миллиона ',

'четыре миллиона ', 'пять миллионов ', 'шесть миллионов ', 'семь миллионов ',

'восемь миллионов ', 'девять миллионов '),

('', '', 'двадцать ', 'тридцать ', 'сорок ', 'пятьдесят ', 'шестьдесят ',

'семьдесят ', 'восемьдесят ', 'девяносто '),

('', 'сто ', 'двести ', 'триста ', 'четыреста ', 'пятьсот ', 'шестьсот ',

'семьсот ', 'восемьсот ', 'девятьсот '));

c: array[0..8, 0..9] ofstring = (

('', 'одна ', 'две ', 'три ', 'четыре ', 'пять ', 'шесть ', 'семь ',

'восемь ', 'девять '),

('', '', 'двадцать ', 'тридцать ', 'сорок ', 'пятьдесят ', 'шестьдесят ',

'семьдесят ', 'восемьдесят ', 'девяносто '),

('', 'сто ', 'двести ', 'триста ', 'четыреста ', 'пятьсот ', 'шестьсот ',

'семьсот ', 'восемьсот ', 'девятьсот '),

('тысячь ', 'одна тысяча ', 'две тысячи ', 'три тысячи ', 'четыре тысячи ',

'пять тысяч ', 'шесть тысяч ', 'семь тысяч ', 'восемь тысяч ',

'девять тысяч '),

('', '', 'двадцать ', 'тридцать ', 'сорок ', 'пятьдесят ', 'шестьдесят ',

'семьдесят ', 'восемьдесят ', 'девяносто '),

('', 'сто ', 'двести ', 'триста ', 'четыреста ', 'пятьсот ', 'шестьсот ',

'семьсот ', 'восемьсот ', 'девятьсот '),

('миллионов ', 'один миллион ', 'два миллиона ', 'три миллиона ',

'четыре миллиона ', 'пять миллионов ', 'шесть миллионов ', 'семь миллионов ',

'восемь миллионов ', 'девять миллионов '),

('', '', 'двадцать ', 'тридцать ', 'сорок ', 'пятьдесят ', 'шестьдесят ',

'семьдесят ', 'восемьдесят ', 'девяносто '),

('', 'сто ', 'двести ', 'триста ', 'четыреста ', 'пятьсот ', 'шестьсот ',

'семьсот ', 'восемьсот ', 'девятьсот '));

b: array[0..9] ofstring =

('десять ', 'одинадцать ', 'двенадцать ', 'тринадцать ', 'четырнадцать ',

'пятнадцать ', 'шестнадцать ', 'семнадцать ', 'восемнадцать ',

'девятнадцать ');

var

pol: boolean;

function longdate(s: string): string; //Длинная дата

var

Pr: TDateTime;

Y, M, D: Word;

begin

Pr := strtodate(s);

DecodeDate(Pr, Y, M, D);

case m of

1: s := 'Января';

2: s := 'Февраля';

3: s := 'Марта';

4: s := 'Апреля';

5: s := 'Мая';

6: s := 'Июня';

7: s := 'Июля';

8: s := 'Августа';

9: s := 'Сентября';

10: s := 'Октября';

11: s := 'Ноября';

12: s := 'Декабря';

end;

result := inttostr(d) + ' ' + s + ' ' + inttostr(y)

end;

function SumToStrin(Value: string): string;

var

s, t: string;

p, pp, i, k: integer;

begin

s := value;

if s = '0'then

t := 'Ноль '

else

begin

p := length(s);

pp := p;

if p > 1then

if (s[p - 1] = '1') and (s[p] >= '0') then

begin

t := b[strtoint(s[p])];

pp := pp - 2;

end;

i := pp;

while i > 0do

begin

if (i = p - 3) and (p > 4) then

if s[p - 4] = '1'then

begin

t := b[strtoint(s[p - 3])] + 'тысяч ' + t;

i := i - 2;

end;

if (i = p - 6) and (p > 7) then

if s[p - 7] = '1'then

begin

t := b[strtoint(s[p - 6])] + 'миллионов ' + t;

i := i - 2;

end;

if i > 0then

begin

k := strtoint(s[i]);

t := a[p - i, k] + t;

i := i - 1;

end;

result := t;

end;

function kolToStrin(Value: string): string;

var

s, t: string;

p, pp, i, k: integer;

begin

s := value;

if s = '0'then

t := 'Ноль '

else

begin

p := length(s);

pp := p;

if p > 1then

if (s[p - 1] = '1') and (s[p] > '0') then

begin

t := b[strtoint(s[p])];

pp := pp - 2;

end;

i := pp;

while i > 0do

begin

if (i = p - 3) and (p > 4) then

if s[p - 4] = '1'then

begin

t := b[strtoint(s[p - 3])] + 'тысяча ' + t;

i := i - 2;

end;

if (i = p - 6) and (p > 7) then

if s[p - 7] = '1'then

begin

t := b[strtoint(s[p - 6])] + 'миллионов ' + t;

i := i - 2;

end;

if i > 0then

begin

k := strtoint(s[i]);

t := c[p - i, k] + t;

i := i - 1;

end;

result := t;

end;

procedure get2str(value: string; var hi, lo: string);

var

p: integer;

begin

p := pos(',', value);

lo := '';

hi := '';

if p = 0then

p := pos('.', value);

if p <> 0then

delete(value, p, 1);

if p = 0then

begin

hi := value;

lo := '00';

exit;

end;

if p > length(value) then

begin

hi := value;

lo := '00';

exit;

end;

if p = 1then

begin

hi := '0';

lo := value;

exit;

end;

begin

hi := copy(value, 1, p - 1);

lo := copy(value, p, length(value));

if length(lo) < 2then

lo := lo + '0';

end;

function sumtostring(value: string): string;

var

hi, lo, valut, loval: string;

pr, er: integer;

begin

get2str(value, hi, lo);

if (hi = '') or (lo = '') then

begin

result := '';

exit;

end;

val(hi, pr, er);

if er <> 0then

begin

result := '';

exit;

end;

if rub = 0then

begin

if hi[length(hi)] = '1'then

valut := 'рубль ';

if (hi[length(hi)] >= '2') and (hi[length(hi)] <= '4') then

valut := 'рубля ';

if (hi[length(hi)] = '0') or (hi[length(hi)] >= '5') or

((strtoint(copy(hi, length(hi) - 1, 2)) > 10) and (strtoint(copy(hi,

length(hi) - 1, 2)) < 15)) then

valut := 'рублей ';

if (lo[length(lo)] = '0') or (lo[length(lo)] >= '5') then

loval := ' копеек';

if lo[length(lo)] = '1'then

loval := ' копейка';

if (lo[length(lo)] >= '2') and (lo[length(lo)] <= '4') then

loval := ' копейки';

end

else

begin

if (hi[length(hi)] = '0') or (hi[length(hi)] >= '5') then

valut := 'долларов ';

if hi[length(hi)] = '1'then

valut := 'доллар ';

if (hi[length(hi)] >= '2') and (hi[length(hi)] <= '4') then

valut := 'доллара ';

if (lo[length(lo)] = '0') or (lo[length(lo)] >= '5') then

loval := ' центов';

if lo[length(lo)] = '1'then

loval := ' цент';

if (lo[length(lo)] >= '2') and (lo[length(lo)] <= '4') then

loval := ' цента';

end;

hi := sumtostrin(inttostr(pr)) + valut;

if lo <> '00'then

begin

val(lo, pr, er);

if er <> 0then

begin

result := '';

exit;

end;

lo := inttostr(pr);

end;

if length(lo) < 2then

lo := '0' + lo;

lo := lo + loval;

hi[1] := AnsiUpperCase(hi[1])[1];

result := hi + lo;

end;

function pfam(s: string): string;

begin

if (s[length(s)] = 'к') or (s[length(s)] = 'ч') and (pol = true) then

s := s + 'у';

if s[length(s)] = 'в'then

s := s + 'у';

if s[length(s)] = 'а'then

begin

delete(s, length(s), 1);

result := s + 'ой';

exit;

end;

if s[length(s)] = 'н'then

s := s + 'у';

if s[length(s)] = 'й'then

begin

delete(s, length(s) - 1, 2);

result := s + 'ому';

end;

if s[length(s)] = 'я'then

begin

delete(s, length(s) - 1, 2);

result := s + 'ой';

exit;

end;

result := s;

end;

function pnam(s: string): string;

begin

pol := true;

if s[length(s)] = 'й'then

begin

delete(s, length(s), 1);

s := s + 'ю';

end;

if s[length(s)] = 'л'then

s := s + 'у';

if s[length(s)] = 'р'then

s := s + 'у';

if s[length(s)] = 'м'then

s := s + 'у';

if s[length(s)] = 'н'then

s := s + 'у';

if s[length(s)] = 'я'then

begin

pol := false;

delete(s, length(s), 1);

s := s + 'е';

end;

if s[length(s)] = 'а'then

begin

pol := false;

delete(s, length(s), 1);

s := s + 'е';

end;

result := s;

end;

function potch(s: string): string;

begin

if s[length(s)] = 'а'then

begin

delete(s, length(s), 1);

s := s + 'е';

end;

if s[length(s)] = 'ч'then

s := s + 'у';

result := s;

end;

function ofam(s: string): string;

begin

if (s[length(s)] = 'к') or (s[length(s)] = 'ч') and (pol = true) then

s := s + 'а';

if s[length(s)] = 'а'then

begin

delete(s, length(s), 1);

result := s + 'ой';

exit;

end;

if s[length(s)] = 'в'then

s := s + 'а';

if s[length(s)] = 'н'then

s := s + 'а';

if s[length(s)] = 'й'then

begin

delete(s, length(s) - 1, 2);

result := s + 'ова';

end;

if s[length(s)] = 'я'then

begin

delete(s, length(s) - 1, 2);

result := s + 'ой';

exit;

end;

result := s;

end;

function onam(s: string): string;

begin

pol := true;

if s[length(s)] = 'а'then

if s[length(s) - 1] = 'г'then

begin

pol := false;

delete(s, length(s), 1);

s := s + 'и';

end

else

begin

pol := false;

delete(s, length(s), 1);

s := s + 'ы';

end;

if s[length(s)] = 'л'then

s := s + 'а';

if s[length(s)] = 'р'then

s := s + 'а';

if s[length(s)] = 'м'then

s := s + 'а';

if s[length(s)] = 'н'then

s := s + 'а';

if s[length(s)] = 'я'then

begin

pol := false;

delete(s, length(s), 1);

s := s + 'и';

end;

if s[length(s)] = 'й'then

begin

delete(s, length(s), 1);

s := s + 'я';

end;

result := s;

end;

function ootch(s: string): string;

begin

if s[length(s)] = 'а'then

begin

delete(s, length(s), 1);

s := s + 'ы';

end;

if s[length(s)] = 'ч'then

s := s + 'а';

result := s;

end;

function padeg(s: string): string;

var

q: tstringlist;

p: integer;

begin

if s <> ''then

begin

q := tstringlist.Create;

p := pos(' ', s);

if p = 0then

p := pos('.', s);

if p = 0then

q.Add(s)

else

begin

q.Add(copy(s, 1, p - 1));

delete(s, 1, p);

p := pos(' ', s);

if p = 0then

p := pos('.', s);

if p = 0then

q.Add(s)

else

begin

q.Add(copy(s, 1, p - 1));

delete(s, 1, p);

p := pos(' ', s);

if p = 0then

p := pos('.', s);

if p = 0then

q.Add(s)

else

begin

q.Add(copy(s, 1, p - 1));

delete(s, 1, p);

end;

if q.Count > 1then

result := result + ' ' + pnam(q[1]);

if q.Count > 0then

result := pfam(q[0]) + result;

if q.Count > 2then

result := result + ' ' + potch(q[2]);

q.Free;

end;

function fio(s: string): string;

var

q: tstringlist;

p: integer;

begin

if s <> ''then

begin

q := tstringlist.Create;

p := pos(' ', s);

if p = 0then

p := pos('.', s);

if p = 0then

q.Add(s)

else

begin

q.Add(copy(s, 1, p - 1));

delete(s, 1, p);

p := pos(' ', s);

if p = 0then

p := pos('.', s);

if p = 0then

q.Add(s)

else

begin

q.Add(copy(s, 1, 1));

delete(s, 1, p);

p := pos(' ', s);

if p = 0then

p := pos('.', s);

if p = 0then

q.Add(copy(s, 1, 1))

else

begin

q.Add(copy(s, 1, 1));

end;

if q.Count > 1then

result := q[0] + ' ' + q[1] + '.';

if q.Count > 2then

result := result + q[2] + '.';

q.Free;

end;

function padegot(s: string): string;

var

q: tstringlist;

p: integer;

begin

if s <> ''then

begin

q := tstringlist.Create;

p := pos(' ', s);

if p = 0then

p := pos('.', s);

if p = 0then

q.Add(s)

else

begin

q.Add(copy(s, 1, p - 1));

delete(s, 1, p);

p := pos(' ', s);

if p = 0then

p := pos('.', s);

if p = 0then

q.Add(s)

else

begin

q.Add(copy(s, 1, p - 1));

delete(s, 1, p);

p := pos(' ', s);

if p = 0then

p := pos('.', s);

if p = 0then

q.Add(s)

else

begin

q.Add(copy(s, 1, p - 1));

delete(s, 1, p);

end;

if q.Count > 1then

result := result + ' ' + onam(q[1]);

if q.Count > 0then

result := ofam(q[0]) + result;

if q.Count > 2then

result := result + ' ' + ootch(q[2]);

q.Free;

end;

procedure getfullfio(s: string; var fnam, lnam, onam: string);

//Получить из строки фамилию имя и отчество сокращенно

begin

fnam := '';

lnam := '';

onam := '';

fnam := copy(s, 1, pos(' ', s));

delete(s, 1, pos(' ', s));

lnam := copy(s, 1, pos(' ', s));

delete(s, 1, pos(' ', s));

onam := s;

end;

begin

rub := 0;

end.

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

s := SumToString('123.00');

Code:

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

>> Конвертация денежных сумм в строковое выражение

Конвертация денежных сумм в строковое выражение впоть до додециллиона,

причем легко наращивается. Небольшая по размеру.

Зависимости: System

Автор: Раков Андрей, klopmail mail.ru, Курчатов

Дата: 17 августа 20012 г.

***************************************************** }

function MoneyToStr(DD: string): string;

{(С) Раков А.В. 05.2002 e-mail: klopmail mail.ru сайт: }

type

TTroyka = array[1..3] of Byte;

TMyString = array[1..19] ofstring[12];

var

S, OutS, S2: string;

k, L, kk: Integer;

Troyka: TTroyka;

V1: TMyString;

Mb: Byte;

const

V11: TMyString =

('один', 'два', 'три', 'четыре', 'пять', 'шесть', 'семь', 'восемь', 'девять',

'десять', 'одиннадцать',

'двенадцать', 'тринадцать', 'четырнадцать', 'пятнадцать', 'шестнадцать',

'семнадцать', 'восемнадцать', 'девятнадцать');

V2: array[1..8] ofstring =

('двадцать', 'тридцать', 'сорок', 'пятьдесят', 'шестьдесят', 'семьдесят',

'восемьдесят', 'девяносто');

V3: array[1..9] ofstring =

('сто', 'двести', 'триста', 'четыреста', 'пятьсот', 'шестьсот', 'семьсот',

'восемьсот', 'девятьсот');

M1: array[1..13, 1..3] ofstring = (('тысяча', 'тысячи', 'тысяч'),

('миллион', 'миллиона', 'миллионов'),

('миллиард', 'миллиарда', 'миллиардов'),

('триллион', 'триллиона', 'триллионов'),

('квадриллион', 'квадриллиона', 'квадриллионов'),

('квинтиллион', 'квинтиллиона', 'квинтиллионов'),

('секстиллион', 'секстиллиона', 'секстиллионов'),

('сентиллион', 'сентиллиона', 'сентиллионов'),

('октиллион', 'октиллиона', 'октиллионов'),

('нониллион', 'нониллиона', 'нониллионов'),

('дециллион', 'дециллиона', 'дециллионов'),

('ундециллион', 'ундециллиона', 'ундециллионов'),

('додециллион', 'додециллиона', 'додециллионов'));

R1: array[1..3] ofstring = ('рубль', 'рубля', 'рублей');

R2: array[1..3] ofstring = ('копейка', 'копейки', 'копеек');

function TroykaToStr(L: ShortInt; TR: TTroyka): string;

var

S: string;

begin

S := '';

if Abs(L) = 1then

begin

V1[1] := 'одна';

V1[2] := 'две';

end

else

begin

V1[1] := 'один';

V1[2] := 'два';

end;

if Troyka[2] = 1then

begin

Troyka[2] := 0;

Troyka[3] := 10 + Troyka[3];

end;

if Troyka[3] <> 0then

S := V1[Troyka[3]];

if Troyka[2] <> 0then

S := V2[Troyka[2] - 1] + ' ' + S;

if Troyka[1] <> 0then

S := V3[Troyka[1]] + ' ' + S;

if (L > 0) and (S <> '') then

case Troyka[3] of

1: S := S + ' ' + M1[L, 1] + ' ';

2..4: S := S + ' ' + M1[L, 2] + ' ';

else

S := S + ' ' + M1[L, 3] + ' ';

end;

TroykaToStr := S;

end;

begin

V1 := V11;

L := 0;

OutS := '';

kk := Pos(',', DD);

if kk = 0then

S := DD

else

S := Copy(DD, 1, kk - 1);

if S = '0'then

S2 := ''

else

S2 := S;

repeat

for k := 3downto1do

if Length(S) > 0then

begin

Troyka[k] := StrToInt(S[Length(S)]);

Delete(S, Length(S), 1);

end

else

Troyka[k] := 0;

OutS := TroykaToStr(L, Troyka) + OutS;

if L = 0then

Mb := Troyka[3];

Inc(L);

until Length(S) = 0;

case Mb of

0: if Length(S2) > 0then

OutS := OutS + ' ' + R1[3] + ' ';

1: OutS := OutS + ' ' + R1[1] + ' ';

2..4: OutS := OutS + ' ' + R1[2] + ' ';

else

OutS := OutS + ' ' + R1[3] + ' ';

end;

S2 := '';

if kk <> 0then

begin

DD := Copy(DD, kk + 1, 2);

if Length(DD) = 1then

DD := DD + '0';

k := StrToInt(DD);

Troyka[1] := 0;

Troyka[2] := k div10;

Troyka[3] := k mod10;

S2 := TroykaToStr(-1, Troyka);

case Troyka[3] of

0: if Troyka[2] = 0then

S := ''

else

S := R2[3];

1: S := R2[1];

2..4: S := R2[2];

else

S := R2[3];

end;

// MoneyToStr:=OutS+IntToStr(k)+' '+S; // если копейки нужны цифрой-эту строку раскоментировать

MoneyToStr := OutS + S2 + ' ' + S; // а эту закоментировать

end;

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

S := MoneyToStr('76576876876976576437654365,98');

Число украинской строкой

2013-09-18T19:29:25+07:00

Code:

unit UkrRecog;

{копирайт непомню чей. Был для русских циферок, а я переделал под

украинские}

{если кто что найдет пришлите

}

{by Andrew Tkachenko, proektwo netcity.ru, Ukraine,

}

interface

const

UkrMonthString: array[1..12] ofstring[9] = (

'січня', 'лютого', 'березня', 'квiтня', 'травня',

'червня', 'липня', 'серпня', 'вересня', 'жовтня',

'листопада', 'грудня');

function UkrRecognizeAmount(Amount: real;

CurrName, CurrSubname: string): string;

implementation

uses Sysutils;

function UkrRecognizeAmount(Amount: real;

CurrName, CurrSubname: string): string;

{* CurrName in [грн.]

CurrSubName in [коп.]

Распознается число <= 999 999 999 999.99*}

const suffBL: string = ' ';

suffDCT: string = 'дцять';

suffNA: string = 'надцять ';

suffDCM: string = 'десят';

suffMZ: string = 'ь';

sot: string = 'сот';

st: string = 'ст';

aa: string = 'а';

ee: string = 'и'; {e}

ii: string = 'і'; {и}

oo: string = 'о';

ov: string = 'ів'; {ов}

C2: string = 'дв';

C3: string = 'тpи';

C4: string = 'чотир';

C5: string = 'п''ят';

C6: string = 'шіст';

C7: string = 'сім';

C8: string = 'вісім';

C9: string = 'дев''ят';

var

i: byte;

sAmount, sdInt, sdDec: string;

IsMln, IsTha {,IsDcm}, IsRange1019: boolean;

currNum, endMlx, sResult: string;

begin

if (amount <= 0) or (amount > 999999999999.99) then

begin

Result := '<<<< Ошибка в диапазоне >>>>';

Exit;

end;

STR(Amount: 16: 2, sAmount);

sdInt := Copy(sAmount, 1, 13);

sdDec := Copy(sAmount, 15, 2);

IsMln := false;

//IsDcm:=false;

IsTha := false;

IsRange1019 := false;

sResult := '';

for i := 1to13do

begin

currNum := Copy(sdInt, i, 1);

if currNum <> suffBL then

begin

case i of

5, 6, 7: if currNum <> '0'then IsMln := true;

8, 9, 10: if currNum <> '0'then IsTha := true;

end;

if i in [2, 5, 8, 11] then{сотни}

begin

if currNum = '1'then sResult := sResult + st + oo + suffBL;

if currNum = '2'then sResult := sResult + C2 + ii + st + ii + suffBL;

if currNum = '3'then sResult := sResult + C3 + st + aa + suffBL;

if currNum = '4'then sResult := sResult + C4 + ee + st + aa + suffBL;

if currNum = '5'then sResult := sResult + C5 + sot + suffBL;

if currNum = '6'then sResult := sResult + C6 + sot + suffBL;

if currNum = '7'then sResult := sResult + C7 + sot + suffBL;

if currNum = '8'then sResult := sResult + C8 + sot + suffBL;

if currNum = '9'then sResult := sResult + C9 + sot + suffBL;

end;

if i in [3, 6, 9, 12] then{десятки}

begin

if currNum = '1'then IsRange1019 := true;

if currNum = '2'then sResult := sResult + C2 + aa + suffDCT + suffBL;

if currNum = '3'then sResult := sResult + C3 + suffDCT + suffBL;

if currNum = '4'then sResult := sResult + 'соpок ';

if currNum = '5'then

sResult := sResult + C5 + suffMZ + suffDCM + suffBL;

if currNum = '6'then

sResult := sResult + C6 + suffMZ + suffDCM + suffBL;

if currNum = '7'then

sResult := sResult + C7 + suffMZ + suffDCM + suffBL;

if currNum = '8'then

sResult := sResult + C8 + suffMZ + suffDCM + suffBL;

if currNum = '9'then

sResult := sResult + 'дев''ян' + oo + st + oo + suffBL;

end;

if i in [4, 7, 10, 13] then{единицы}

begin

if (currNum = '0') then

if IsRange1019 then sResult := sResult + suffDCM + suffMZ + suffBL;

if (currNum = '1') then

begin

if (i = 13) and (not IsRange1019) then

sResult := sResult + 'одна '

else

begin

if (i = 10) and (IsRange1019) then

sResult := sResult + 'оди'

elseif (i = 10) and (not IsRange1019) then

sResult := sResult + 'одна '

else

sResult := sResult + 'один'{ин};

if IsRange1019 and (i = 13) then

sResult := sResult + 'адцять' + suffBL

elseif IsRange1019 then

sResult := sResult + suffNA

else

sResult := sResult + suffBL;

end;

if (currNum = '2') then

begin

sResult := sResult + C2;

if (i = 10) and (IsRange1019 = False) then

sResult := sResult + ii

elseif (i = 10) or (IsRange1019) then

sResult := sResult + aa

else

sResult := sResult + {aa} ii;

if IsRange1019 then

sResult := sResult + suffNA

else

sResult := sResult + suffBL;

end;

if (currNum = '3') then

begin

sResult := sResult + C3;

if IsRange1019 then

sResult := sResult + suffNA

else

sResult := sResult + suffBL;

end;

if (currNum = '4') then

begin

sResult := sResult + C4;

if IsRange1019 then

sResult := sResult + suffNA

else

sResult := sResult + ee + suffBL;

end;

if (currNum = '5') then

begin

sResult := sResult + C5;

if IsRange1019 then

sResult := sResult + suffNA

else

sResult := sResult + suffMZ + suffBL;

end;

if (currNum = '6') then

begin

sResult := sResult + C6;

if IsRange1019 then

sResult := sResult + suffNA

else

sResult := sResult + suffMZ + suffBL;

end;

if (currNum = '7') then

begin

sResult := sResult + C7;

if IsRange1019 then

sResult := sResult + suffNA

else

sResult := sResult + suffBL;

end; if (currNum = '8') then

begin

sResult := sResult + C8;

if IsRange1019 then

sResult := sResult + suffNA

else

sResult := sResult + suffBL;

end; if (currNum = '9') then

begin

sResult := sResult + C9;

if IsRange1019 then

sResult := sResult + suffNA

else

sResult := sResult + suffMZ + suffBL;

end;

endMlx := '';

case i of

begin

if IsRange1019 then

endMlx := ov + suffBL

elseif currNum = '1'then

endMlx := suffBL

elseif (currNum = '2') or (currNum = '3') or (currNum = '4') then

endMlx := aa + suffBL

else

endMlx := ov + suffBL;

sResult := sResult + 'мiльярд' + endMlx;

end;

7: if IsMln then

begin

if IsRange1019 then

endMlx := ov + suffBL

elseif currNum = '1'then

endMlx := suffBL

elseif (currNum = '2') or (currNum = '3') or (currNum = '4') then

endMlx := aa + suffBL

else

endMlx := ov + suffBL;

sResult := sResult + 'мiльйон' + endMlx;

end;

10: if IsTha then

begin

if IsRange1019 then

endMlx := suffBL

elseif currNum = '1'then

endMlx := aa + suffBL

elseif (currNum = '2') or (currNum = '3') or (currNum = '4') then

endMlx := ii + suffBL

else

endMlx := suffBL;

sResult := sResult + 'тисяч' + endMlx;

end;

end; {case}

if i in [4, 7, 10, 13] then IsRange1019 := false;

end; {IF}

end; {FOR}

sResult := sResult + CurrName + ',' + suffBL + sdDec + suffBL + CurrSubname;

sResult := AnsiUpperCase(sResult[1]) + Copy(sResult, 2, length(sResult) - 1);

Result := sResult;

end;

end.

С уважением,

Andrew Tkachenko

ООО "Проект ВО"

Украина, г.Харьков