{ **** UBPFD *********** by delphibase.endimus.com ****
>> Сумма и количество прописью, работа с падежами
Несколько функций для работы с строками:
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;
interfaceuses
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);
//Получить из строки фамилию имя и отчество сокращенноimplementationconst
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 := "Ноль "
elsebegin
p := length(s);
pp := p;
if p > 1 thenif (s[p - 1] = "1") and (s[p] >= "0") thenbegin
t := b[strtoint(s[p])];
pp := pp - 2;
end;
i := pp;
while i > 0 dobeginif (i = p - 3) and (p > 4) thenif s[p - 4] = "1" thenbegin
t := b[strtoint(s[p - 3])] + "тысяч " + t;
i := i - 2;
end;
if (i = p - 6) and (p > 7) thenif s[p - 7] = "1" thenbegin
t := b[strtoint(s[p - 6])] + "миллионов " + t;
i := i - 2;
end;
if i > 0 thenbegin
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 := "Ноль "
elsebegin
p := length(s);
pp := p;
if p > 1 thenif (s[p - 1] = "1") and (s[p] > "0") thenbegin
t := b[strtoint(s[p])];
pp := pp - 2;
end;
i := pp;
while i > 0 dobeginif (i = p - 3) and (p > 4) thenif s[p - 4] = "1" thenbegin
t := b[strtoint(s[p - 3])] + "тысяча " + t;
i := i - 2;
end;
if (i = p - 6) and (p > 7) thenif s[p - 7] = "1" thenbegin
t := b[strtoint(s[p - 6])] + "миллионов " + t;
i := i - 2;
end;
if i > 0 thenbegin
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 thenbegin
hi := value;
lo := "00";
exit;
end;
if p > length(value) thenbegin
hi := value;
lo := "00";
exit;
end;
if p = 1 thenbegin
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 = "") thenbegin
result := "";
exit;
end;
val(hi, pr, er);
if er <> 0 thenbegin
result := "";
exit;
end;
if rub = 0 thenbeginif 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 := " копейки";
endelsebeginif (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" thenbegin
val(lo, pr, er);
if er <> 0 thenbegin
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;
beginif (s[length(s)] = "к") or (s[length(s)] = "ч") and (pol = true) then
s := s + "у";
if s[length(s)] = "в" then
s := s + "у";
if s[length(s)] = "а" thenbegin
delete(s, length(s), 1);
result := s + "ой";
exit;
end;
if s[length(s)] = "н" then
s := s + "у";
if s[length(s)] = "й" thenbegin
delete(s, length(s) - 1, 2);
result := s + "ому";
end;
if s[length(s)] = "я" thenbegin
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)] = "й" thenbegin
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)] = "я" thenbegin
pol := false;
delete(s, length(s), 1);
s := s + "е";
end;
if s[length(s)] = "а" thenbegin
pol := false;
delete(s, length(s), 1);
s := s + "е";
end;
result := s;
end;
function potch(s: string): string;
beginif s[length(s)] = "а" thenbegin
delete(s, length(s), 1);
s := s + "е";
end;
if s[length(s)] = "ч" then
s := s + "у";
result := s;
end;
function ofam(s: string): string;
beginif (s[length(s)] = "к") or (s[length(s)] = "ч") and (pol = true) then
s := s + "а";
if s[length(s)] = "а" thenbegin
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)] = "й" thenbegin
delete(s, length(s) - 1, 2);
result := s + "ова";
end;
if s[length(s)] = "я" thenbegin
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)] = "а" thenif s[length(s) - 1] = "г" thenbegin
pol := false;
delete(s, length(s), 1);
s := s + "и";
endelsebegin
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)] = "я" thenbegin
pol := false;
delete(s, length(s), 1);
s := s + "и";
end;
if s[length(s)] = "й" thenbegin
delete(s, length(s), 1);
s := s + "я";
end;
result := s;
end;
function ootch(s: string): string;
beginif s[length(s)] = "а" thenbegin
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;
beginif s <> "" thenbegin
q := tstringlist.Create;
p := pos(" ", s);
if p = 0 then
p := pos(".", s);
if p = 0 then
q.Add(s)
elsebegin
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)
elsebegin
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)
elsebegin
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;
beginif s <> "" thenbegin
q := tstringlist.Create;
p := pos(" ", s);
if p = 0 then
p := pos(".", s);
if p = 0 then
q.Add(s)
elsebegin
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)
elsebegin
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))
elsebegin
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;
beginif s <> "" thenbegin
q := tstringlist.Create;
p := pos(" ", s);
if p = 0 then
p := pos(".", s);
if p = 0 then
q.Add(s)
elsebegin
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)
elsebegin
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)
elsebegin
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.
Если Вас заинтересовала или понравилась информация по разработке на Delph - "Сумма и количество прописью, работа с падежами", Вы можете поставить закладку в социальной сети или в своём блоге на данную страницу: Так же Вы можете задать вопрос по работе этого модуля или примера через форму обратной связи, в сообщение обязательно указывайте название или ссылку на статью!