Сумма и количество прописью, работа с падежами

=== Сумма и количество прописью, работа с падежами ===
{ **** UBPFD *********** by kladovka.net.ru ****
>> Сумма и количество прописью, работа с падежами
Несколько функций для работы с строками:
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, Архангельск
Copyright: Eda
Дата: 13 июня 2003 г.
********************************************** }
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] of string = (
 (, 'один ', 'два ', 'три ', 'четыре ', 'пять ',
 'шесть ', 'семь ', 'восемь ', 'девять '),
 (, , 'двадцать ', 'тридцать ', 'сорок ',
 'пятьдесят ', 'шестьдесят ', 'семьдесят ',
 'восемьдесят ', 'девяносто '),
 (, 'сто ', 'двести ', 'триста ', 'четыреста ',
 'пятьсот ', 'шестьсот ', 'семьсот ', 'восемьсот ',
 'девятьсот '),
 ('тысяч ', 'одна тысяча ', 'две тысячи ',
 'три тысячи ', 'четыре тысячи ', 'пять тысяч ',
 'шесть тысяч ', 'семь тысяч ', 'восемь тысяч ',
 'девять тысяч '),
 (, , 'двадцать ', 'тридцать ', 'сорок ',
 'пятьдесят ', 'шестьдесят ', 'семьдесят ',
 'восемьдесят ', 'девяносто '),
 (, 'сто ', 'двести ', 'триста ', 'четыреста ',
 'пятьсот ', 'шестьсот ', 'семьсот ', 'восемьсот ',
 'девятьсот '),
 ('миллионов ', 'один миллион ', 'два миллиона ',
 'три миллиона ', 'четыре миллиона ',
 'пять миллионов ', 'шесть миллионов ',
 'семь миллионов ', 'восемь миллионов ',
 'девять миллионов '),
 (, , 'двадцать ', 'тридцать ', 'сорок ',
 'пятьдесят ', 'шестьдесят ', 'семьдесят ',
 'восемьдесят ', 'девяносто '),
 (, 'сто ', 'двести ', 'триста ', 'четыреста ',
 'пятьсот ', 'шестьсот ', 'семьсот ', 'восемьсот ',
 'девятьсот '));
 c: array[0..8, 0..9] of string = (
 (, 'одна ', 'две ', 'три ', 'четыре ', 'пять ',
 'шесть ', 'семь ', 'восемь ', 'девять '),
 (, , 'двадцать ', 'тридцать ', 'сорок ',
 'пятьдесят ', 'шестьдесят ', 'семьдесят ',
 'восемьдесят ', 'девяносто '),
 (, 'сто ', 'двести ', 'триста ', 'четыреста ',
 'пятьсот ', 'шестьсот ', 'семьсот ', 'восемьсот ',
 'девятьсот '),
 ('тысячь ', 'одна тысяча ', 'две тысячи ',
 'три тысячи ', 'четыре тысячи ', 'пять тысяч ',
 'шесть тысяч ', 'семь тысяч ', 'восемь тысяч ',
 'девять тысяч '),
 (, , 'двадцать ', 'тридцать ', 'сорок ',
 'пятьдесят ', 'шестьдесят ', 'семьдесят ',
 'восемьдесят ', 'девяносто '),
 (, 'сто ', 'двести ', 'триста ', 'четыреста ',
 'пятьсот ', 'шестьсот ', 'семьсот ', 'восемьсот ',
 'девятьсот '),
 ('миллионов ', 'один миллион ', 'два миллиона ',
 'три миллиона ', 'четыре миллиона ',
 'пять миллионов ', 'шесть миллионов ',
 'семь миллионов ', 'восемь миллионов ',
 'девять миллионов '),
 (, , 'двадцать ', 'тридцать ', 'сорок ',
 'пятьдесят ', 'шестьдесят ', 'семьдесят ',
 'восемьдесят ', 'девяносто '),
 (, 'сто ', 'двести ', 'триста ', 'четыреста ',
 'пятьсот ', 'шестьсот ', 'семьсот ', 'восемьсот ',
 'девятьсот '));
 b: array[0..9] of string =
 ('десять ', 'одинадцать ', 'двенадцать ',
 'тринадцать ', 'четырнадцать ', 'пятнадцать ',
 'шестнадцать ', 'семнадцать ', 'восемнадцать ',
 'девятнадцать ');
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 > 1 then
 if (s[p - 1] = '1') and (s[p] >= '0') then
 begin
 t := b[StrToInt(s[p])];
 pp := pp - 2;
 end;
 i := pp;
 while i > 0 do
 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 > 0 then
 begin
 k := StrToInt(s[i]);
 t := a[p - i, k] + t;
 i := i - 1;
 end;
 end;
 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 > 1 then
 if (s[p - 1] = '1') and (s[p] > '0') then
 begin
 t := b[StrToInt(s[p])];
 pp := pp - 2;
 end;
 i := pp;
 while i > 0 do
 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 > 0 then
 begin
 k := StrToInt(s[i]);
 t := c[p - i, k] + t;
 i := i - 1;
 end;
 end;
 end;
 Result := t;
end;
procedure get2str(Value: string; var hi, lo: string);
var
 p: integer;
begin
 p := pos(',', Value);
 lo := ;
 hi := ;
 if p = 0 then
 p := pos('.', Value);
 if p <> 0 then
 Delete(Value, p, 1);
 if p = 0 then
 begin
 hi := Value;
 lo := '00';
 exit;
 end;
 if p > length(Value) then
 begin
 hi := Value;
 lo := '00';
 exit;
 end;
 if p = 1 then
 begin
 hi := '0';
 lo := Value;
 exit;
 end;
 begin
 hi := copy(Value, 1, p - 1);
 lo := copy(Value, p, length(Value));
 if length(lo) < 2 then
 lo := lo + '0';
 end;
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 <> 0 then
 begin
 Result := ;
 exit;
 end;
 if rub = 0 then
 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 <> 0 then
 begin
 Result := ;
 exit;
 end;
 lo := IntToStr(pr);
 end;
 if length(lo) < 2 then
 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 = 0 then
 p := Pos('.', s);
 if p = 0 then
 q.Add(s)
 else
 begin
 q.Add(Copy(s, 1, p-1));
 Delete(s, 1, p);
 p := Pos(' ', s);
 if p = 0 then
 p := Pos('.', s);
 if p = 0 then
 q.Add(s)
 else
 begin
 q.Add(Copy(s, 1, p-1));
 Delete(s, 1, p);
 p := Pos(' ', s);
 if p = 0 then
 p := Pos('.', s);
 if p = 0 then
 q.Add(s)
 else 
 begin
 q.Add(Copy(s, 1, p-1));
 Delete(s, 1, p);
 end;
 end;
 end;
 if q.Count > 1 then
 Result := Result + ' ' + pnam(q[1]);
 if q.Count > 0 then
 Result := pfam(q[0]) + Result;
 if q.Count > 2 then
 Result := Result + ' ' + potch(q[2]);
 q.Free();
 end;
end;
function fio(s: string): string;
var q: TStringList;
 p: Integer;
begin
 if s <> then
 begin
 q := TStringList.Create();
 p := Pos(' ', s);
 if p = 0 then
 p := Pos('.', s);
 if p = 0 then
 q.Add(s)
 else
 begin
 q.Add(Copy(s, 1, p-1));
 Delete(s, 1, p);
 p := Pos(' ', s);
 if p = 0 then
 p := Pos('.', s);
 if p = 0 then
 q.Add(s)
 else
 begin
 q.Add(Copy(s, 1, 1));
 Delete(s, 1, p);
 p := Pos(' ', s);
 if p = 0 then
 p := Pos('.', s);
 if p = 0 then
 q.Add(Copy(s, 1, 1))
 else
 begin
 q.Add(Copy(s, 1, 1));
 end;
 end;
 end;
 if q.Count > 1 then
 Result := q[0] + ' ' + q[1] + '.';
 if q.Count > 2 then
 Result := Result + q[2] + '.';
 q.Free();
 end;
end;
function padegot(s: string): string;
var q: TStringList;
 p: Integer;
begin
 if s <> then
 begin
 q := TStringList.Create();
 p := Pos(' ', s);
 if p = 0 then
 p := Pos('.', s);
 if p = 0 then
 q.Add(s)
 else
 begin
 q.Add(Copy(s, 1, p-1));
 Delete(s, 1, p);
 p := Pos(' ', s);
 if p = 0 then
 p := Pos('.', s);
 if p = 0 then
 q.Add(s)
 else
 begin
 q.Add(Copy(s, 1, p-1));
 Delete(s, 1, p);
 p := Pos(' ', s);
 if p = 0 then
 p := Pos('.', s);
 if p = 0 then
 q.Add(s)
 else
 begin
 q.Add(Copy(s, 1, p-1));
 Delete(s,1,p);
 end;
 end;
 end;
 if q.Count > 1 then
 Result := Result + ' ' + onam(q[1]);
 if q.Count > 0 then
 Result := ofam(q[0]) + Result;
 if q.Count > 2 then
 Result := Result + ' ' + ootch(q[2]);
 q.Free;
 end;
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'); 
Source: kladovka.net.ru
ID: 00178