Добро пожаловать в форум, Guest  >>   Войти | Регистрация | Поиск | Правила | В избранное | Подписаться
Все форумы / Delphi Новый топик    Ответить
 Сумма прописью  [new]
vislex
Member

Откуда: Москва
Сообщений: 38
Здравствуйте!

Посоветуйте пожалуйста 100% работающую функцию для получения суммы прописью. Кто какие функции использует?

Спасибо
С Уважением, Алексей
31 мар 03, 16:47    [160778]     Ответить | Цитировать Сообщить модератору
 Re: Сумма прописью  [new]
Cooper
Member

Откуда: Фром Москоу
Сообщений: 3939
https://www.sql.ru/forum/actualthread.aspx?bid=20&tid=19377
31 мар 03, 16:49    [160782]     Ответить | Цитировать Сообщить модератору
 Re: Сумма прописью  [new]
alexia
Member

Откуда: Санкт-Петербург
Сообщений: 460
Есть у меня сырники, правда никогда не пользовался... Попробуй


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 = 1 Then
case i of
1: CifrToStr :='сто';
2: CifrToStr :='двести';
3: CifrToStr :='триста';
4: CifrToStr :='четыреста';
5: CifrToStr :='пятьсот';
6: CifrToStr :='шестьсот';
7: CifrToStr :='семьсот';
8: CifrToStr :='восемьсот';
9: CifrToStr :='девятьсот';
0: CifrToStr :='';
end
else if Pr = 2 Then
case i of
1: CifrToStr :='';
2: CifrToStr :='двадцать';
3: CifrToStr :='тридцать';
4: CifrToStr :='сорок';
5: CifrToStr :='пятьдесят';
6: CifrToStr :='шестьдесят';
7: CifrToStr :='семьдесят';
8: CifrToStr :='восемьдесят';
9: CifrToStr :='девяносто';
0: CifrToStr :='';
end
else if Pr = 3 Then
case i of
1: if Padeg =1 Then CifrToStr :='один'
else CifrToStr :='одна';
2: if Padeg =1 Then CifrToStr :='два'
else CifrToStr :='две';
3: CifrToStr :='три';
4: CifrToStr :='четыре';
5: CifrToStr :='пять';
6: CifrToStr :='шесть';
7: CifrToStr :='семь';
8: CifrToStr :='восемь';
9: CifrToStr :='девять';
0: CifrToStr :='';
end
else if Pr = 4 Then
case i of
1: CifrToStr :='одиннадцать';
2: CifrToStr :='двенадцать';
3: CifrToStr :='тринадцать';
4: CifrToStr :='четырнадцать';
5: CifrToStr :='пятнадцать';
6: CifrToStr :='шестнадцать';
7: CifrToStr :='семнадцать';
8: CifrToStr :='восемнадцать';
9: CifrToStr :='девятнадцать';
0: CifrToStr :='десять';


end;
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;
end;
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) = 3 Then
S := S+' '+CifrToStr(Copy(Group,1,1),1,Padeg);
S := S+' '+CifrToStr(Copy(Group,Length(Group),1),4,Padeg);
end
else
for i:=1 to 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) = 0 Then
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) >3 Do
Begin
if i = 1 Then 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 = 1 Then 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;
31 мар 03, 16:52    [160788]     Ответить | Цитировать Сообщить модератору
 Re: Сумма прописью  [new]
mitritch
Member

Откуда: Королев МО
Сообщений: 73
Попробуй это. Хочешь далай DLL, а хочешь подключай так...
unit MonToStr;

interface
function sMoneyInWords( Nin: currency ): string; export;
function szMoneyInWords( Nin: currency ): PChar; export;
{ Денежная сумма Nin в рублях и копейках прописью
1997, в.2.1, by О.В.Болдырев}
var
Result : integer;

implementation
uses SysUtils,Dialogs,Math;

type
tri=string;
mood=1..2;
gender=(m,f);
uns =array[0..9] of string[7];
tns =array[0..9] of string[13];
decs=array[0..9] of string[12];
huns=array[0..9] of string[10];
nums=array[0..4] of string[8];
money=array[1..2] of string[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 div 10) mod 10) <> 1 then
case (Arg mod 10) 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 mod 10;
iTri2 := iTri2 div 10;
end;

begin
iTri := trunc(Nr/IntPower(1000,i));
Nr := Nr - int( iTri*IntPower(1000,i));
iTri2:=iTri;
if iTri > 0 then
begin
un := GetDigit;
de := GetDigit;
ce := GetDigit;
if i=1 then g:=f
else g:=m; {женского рода только тысяча}

str := TrimRight(str)+' '+Hundreds[ce];
if de = 1 then
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;
end;

if length(numericals) > 1 then
begin
str := TrimRight(str)+' '+numericals;
str := TrimRight(str)+ends[g,1,EndingIndex(iTri)];
end;
end; //triad is 0 ?

if i=0 then Exit;
Dec(i);
Triad;
end;

begin
str := '';
Nr := int( Nin );
Fr := round( Nin*100 + 0.00000001 ) mod 100;
if Nr>0 then 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,ends[m,2,EndingIndex(iTri)],
Fr, RusMon,ends[f,2,EndingIndex(Fr)]]);
str := (ANSIUpperCase(copy(str,1,1)));
str[Length(str)+1] := #0;
Result := str;
end;

function szMoneyInWords( Nin: currency ): PChar;
begin
sMoneyInWords(Nin);
Result := @(str);
end;

end.
31 мар 03, 17:10    [160802]     Ответить | Цитировать Сообщить модератору
 Re: Сумма прописью  [new]
KirillovA
Member

Откуда: ок на оби
Сообщений: 2294
А у меня короче :)) :
//деньги строкой

var
NumEd: array[1..19] of string = ('один ', 'два ', 'три ', 'четыре ', 'пять ', 'шесть ', 'семь ', 'восемь ', 'девять ', 'десять ', 'одиннадцать ', 'двенадцать ', 'тринадцать ', 'четырнадцать ', 'пятнадцать ', 'шестнадцать ', 'семнадцать ', 'восемнадцать ', 'девятнадцать ');
NumEd1: array[1..2] of string = ('одна ', 'две ');
NumDec: array[2..9] of string = ('двадцать ', 'тридцать ', 'сорок ', 'пятьдесят ', 'шестьдесят ', 'семьдесят ', 'восемьдесят ', 'девяносто ');
NumSot: array[1..9] of string = ('сто ', 'двести ', 'триста ', 'четыреста ', 'пятьсот ', 'шестьсот ', 'семьсот ', 'восемьсот ', 'девятьсот ');
Xlion0: array[1..3] of string = ('тысяч ', 'миллионов ', 'миллиардов ');
Xlion1: array[1..3] of string = ('тысяча ', 'миллион ', 'миллиард ');
Xlion2: array[1..3] of string = ('тысячи ', 'миллиона ', 'миллиарда ');
function MoneyToString(Money: Double): string;
var Money3, MoneyI, MoneyK, Digit, LastDigit, T: Integer;
Sto, Kop: string;
begin
Result := '';
MoneyI := Trunc(Money);
MoneyK := Round((Money - MoneyI) * 100);
T := 0;
while MoneyI > 0 do begin
Money3 := MoneyI mod 1000;
MoneyI := MoneyI div 1000;
Sto := '';
if (Money3 mod 100) < 20 then begin
LastDigit := Money3 mod 20;
if LastDigit > 0 then
if (T = 1) and (LastDigit in [1..2]) then Sto := NumEd1[LastDigit]
else Sto := NumEd[LastDigit];
Money3 := Money3 div 100;
end else begin
LastDigit := Money3 mod 10;
if LastDigit > 0 then
if (T = 1) and (LastDigit in [1..2]) then Sto := NumEd1[LastDigit]
else Sto := NumEd[LastDigit];
Money3 := Money3 div 10;
Digit := Money3 mod 10;
if Digit > 0 then Sto := NumDec[Digit] + Sto;
Money3 := Money3 div 10;
end;
if Money3 > 0 then Sto := NumSot[Money3] + Sto;
if T > 0 then begin
if LastDigit = 1 then Sto := Sto + Xlion1[T]
else if LastDigit in [2..4] then Sto := Sto + Xlion2[T]
else Sto := Sto + Xlion0[T];
end;
T := T + 1;
Result := Sto + Result;
end;
Kop := IntToStr(MoneyK mod 10);
MoneyK := MoneyK div 10;
Kop := IntToStr(MoneyK) + Kop;
Result := Result + 'руб. ' + Kop + ' коп.';
end;
31 мар 03, 20:11    [160957]     Ответить | Цитировать Сообщить модератору
Между сообщениями интервал более 1 года.
 Re: Сумма прописью  [new]
ZardoZ
Member

Откуда:
Сообщений: 83
Гугл привел к этой древней теме. Последняя реализация работает, но в ней есть ошибка. Нужно проверять, что у нас все 0 в текущем порядке. Иначе получите, например, не миллион рублей, а миллион тысяч рублей.

 while MoneyI > 0 do
  begin
    Money3 := MoneyI mod 1000;
    StartMod := Money3;   //добавить
    MoneyI := MoneyI div 1000;


...

    if T > 0 then
    begin
      if LastDigit = 1 then
        Sto := Sto + Xlion1[T]
      else
      if LastDigit in [2..4] then
        Sto := Sto + Xlion2[T]
      else
      if StartMod > 0 then  //добавить
        Sto := Sto + Xlion0[T];
    end;
13 апр 19, 22:12    [21861356]     Ответить | Цитировать Сообщить модератору
 Re: Сумма прописью  [new]
Foxpc
Member

Откуда:
Сообщений: 162
Есть такая реализация
+
program Project1;

{$APPTYPE CONSOLE}
{$R *.res}
uses
  System.SysUtils;

const
  NfFull = 0; // Полное название триад:  тысяча, миллион, ...
  NfShort = 4; // Краткое название триад:  тыс., млн., ...

  NfMale = 0; // Мужской род
  NfFemale = 1; // Женский род
  NfMiddle = 2; // Средний род

function G_NumToStr(N: Int64; var S: string; FormatFlags: LongWord): Integer;
  function ModDiv10(var V: LongWord): Integer;
  begin
    Result := V mod 10;
    V := V div 10;
  end;

const
  M_Ed: array [1 .. 9] of string = ('один ', 'два ', 'три ', 'четыре ', 'пять ', 'шесть ', 'семь ',
    'восемь ', 'девять ');
  W_Ed: array [1 .. 9] of string = ('одна ', 'две ', 'три ', 'четыре ', 'пять ', 'шесть ', 'семь ',
    'восемь ', 'девять ');
  G_Ed: array [1 .. 9] of string = ('одно ', 'два ', 'три ', 'четыре ', 'пять ', 'шесть ', 'семь ',
    'восемь ', 'девять ');
  E_Ds: array [0 .. 9] of string = ('десять ', 'одиннадцать ', 'двенадцать ', 'тринадцать ',
    'четырнадцать ', 'пятнадцать ', 'шестнадцать ', 'семнадцать ', 'восемнадцать ',
    'девятнадцать ');
  D_Ds: array [2 .. 9] of string = ('двадцать ', 'тридцать ', 'сорок ', 'пятьдесят ', 'шестьдесят ',
    'семьдесят ', 'восемьдесят ', 'девяносто ');
  U_Hd: array [1 .. 9] of string = ('сто ', 'двести ', 'триста ', 'четыреста ', 'пятьсот ',
    'шестьсот ', 'семьсот ', 'восемьсот ', 'девятьсот ');
  M_Tr: array [1 .. 6, 0 .. 3] of string = (('тыс. ', 'тысяча ', 'тысячи ', 'тысяч '),
    ('млн. ', 'миллион ', 'миллиона ', 'миллионов '), ('млрд. ', 'миллиард ', 'миллиарда ',
    'миллиардов '), ('трлн. ', 'триллион ', 'триллиона ', 'триллионов '),
    ('квадр. ', 'квадриллион ', 'квадриллиона ', 'квадриллионов '),
    ('квинт. ', 'квинтиллион ', 'квинтиллиона ', 'квинтиллионов '));
var
  V1: Int64;
  VArr: array [0 .. 6] of Integer;
  I, E, D, H, Count: Integer;
begin
  Result := 3;
  if N = 0 then
  begin
    S := 'ноль ';
    Exit;
  end;
  if N > 0 then
    S := ''
  else if N <> $8000000000000000 then
  begin
    N := -N;
    S := 'минус ';
  end else begin { -9.223.372.036.854.775.808 }
    if FormatFlags and NfShort = 0 then
      S := 'минус девять квинтиллионов двести двадцать три квадриллиона' +
        ' триста семьдесят два триллиона тридцать шесть миллиардов' +
        ' восемьсот пятьдесят четыре миллиона семьсот семьдесят пять' + ' тысяч восемьсот восемь '
    else
      S := 'минус девять квинт. двести двадцать три квадр. триста' +
        ' семьдесят два трлн. тридцать шесть млрд. восемьсот пятьдесят' +
        ' четыре млн. семьсот семьдесят пять тыс. восемьсот восемь ';
    Exit;
  end;
  Count := 0;
  repeat
    V1 := N div 1000;
    VArr[Count] := N - (V1 * 1000);
    N := V1;
    Inc(Count);
  until V1 = 0;
  for I := Count - 1 downto 0 do
  begin
    H := VArr[I];
    Result := 3;
    if H <> 0 then
    begin
      E := ModDiv10(LongWord(H));
      D := ModDiv10(LongWord(H));
      if D <> 1 then
      begin
        if E = 1 then
          Result := 1
        else if (E >= 2) and (E <= 4) then
          Result := 2;
        if (H <> 0) and (D <> 0) then
          S := S + U_Hd[H] + D_Ds[D]
        else if H <> 0 then
          S := S + U_Hd[H]
        else if D <> 0 then
          S := S + D_Ds[D];
        if E <> 0 then
          if I = 0 then
            case FormatFlags and 3 of
              0: S := S + M_Ed[E];
              1: S := S + W_Ed[E];
              2: S := S + G_Ed[E];
            else S := S + '#### ';
            end else if I = 1 then
            S := S + W_Ed[E]
          else
            S := S + M_Ed[E];
      end else if H = 0 then
        S := S + E_Ds[E]
      else
        S := S + U_Hd[H] + E_Ds[E];
      if I <> 0 then
      begin
        if FormatFlags and NfShort = 0 then
          S := S + M_Tr[I, Result]
        else
          S := S + M_Tr[I, 0];
      end;
    end;
  end;
end;

var
  Sint: Int64;
  SoutStr: string;

begin
  try
    while True do
    begin
      Readln(Sint);
      G_NumToStr(Sint, SoutStr, NfFull);
      Writeln(SoutStr);
    end;

  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;

end.
14 апр 19, 15:10    [21861577]     Ответить | Цитировать Сообщить модератору
Все форумы / Delphi Ответить