unit Numinwrd;

interface
function sMoneyInWords( Nin: double ): string; export;
function szMoneyInWords( Nin: double ): PChar; export;

implementation
uses SysUtils,Dialogs,Math;

type
  tri=string[ 4 ];
  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: double ): string; { Число Nin прописью, как функция }
var
  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 :=  0 ;
    if Nr >  0  then
      begin
        iTri := trunc(Nr/IntPower( 1000 ,i));
        Nr := Nr - int( iTri*IntPower( 1000 ,i));
      end;
    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[i]) >  1  then
      begin
        str := TrimRight(str)+' '+numericals[i];
        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( 100 *frac(Nin)+ 0 . 0000001 );
  if Fr =  100  then
    begin
     Fr :=  0 ;
     Nr := Nr+ 1 ;
    end;
  if Nr =  0  then
    Order :=  0 
  else
    Order := trunc(Log10(Nr)/ 3 );
  if Order > High(numericals) then
    raise Exception.Create('Слишком большое число для суммы прописью');
  i:= Order;
  Triad;
  if str = '' then
    str :=
     Format('%s %s%s %.2d %s%s', ['ноль',RusMon[ 1 ],ends[m, 2 , 3 ],
                                  Fr, RusMon[ 2 ],ends[f, 2 ,EndingIndex(Fr)]])
  else
    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: double ): PChar;
begin
  sMoneyInWords(Nin);
  Result := @(str[ 1 ]);
end;

end.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    function ConvertDateToString(Date : TDateTime): string;
  end;

var
  Form1: TForm1;
const MonthNames  : array [ 1 .. 12 ] of string = ('января','февраля','марта','апреля','мая','июня',
                                              'июля','августа','сентября','октября','ноября','декабря');
      NamesOfThousand0  : array [ 1 .. 2 ] of string  = ('тысячного','двухтысячного');
      NamesOfThousand   : array [ 1 .. 2 ] of string  = ('одна тысяча','две тысячи');
      NamesOfHandreds0  : array [ 1 .. 9 ] of string =('сотого','двухсотого','трехсотого','четырехсотого','пятисотого','шестисотого',
                                                   'семисотого','восьмисотого','девятисотого');
      NamesOfHandreds   : array [ 1 .. 9 ] of string =('сто','двести','триста','четыреста','пятьсот','шестьсот',
                                                   'семьсот','восемьсот','девятьсот');
      NamesOfTens00     : array [ 1 .. 3 ] of string  = ('десятое','двадцатое','тридцатое');
      NamesOfTens0      : array [ 1 .. 9 ] of string  = ('десятого','двадцатого','тридцатого','сорокового','пятидесятого',
                                                    'шестидесятого','семидесятого','восьмидесятого','девяностого');
      NamesOfTens       : array [ 2 .. 9 ] of string  = ('двадцать','тридцать','сорок','пятьдесят','шестьдесят',
                                                    'семьдесят','восемьдесят','девяносто');
      NamesOfFistTen0   : array [ 1 .. 9 ] of string = ('одинадцатое','двенадцатое','тринадцатое','четырнадцатое','пятнадцатое',
                                                    'шестнадцатое','семнадцатое','восемьнадцатое','девятнадцатое');
      NamesOfFistTen    : array [ 1 .. 9 ] of string = ('одинадцатого','двенадцатого','тринадцатого','четырнадцатого','пятнадцатого',
                                                    'шестнадцатого','семнадцатого','восемьнадцатого','девятнадцатого');
      NamesOfUnits0     : array [ 1 .. 9 ] of string  = ('первое','второе','третье','четвертое','пятое',
                                                     'шестое','седьмое','восьмое','девятое');
      NamesOfUnits      : array [ 1 .. 9 ] of string  = ('первого','второго','третьего','четвертого','пятого',
                                                     'шестого','седьмого','восьмого','девятого');

implementation

{$R *.dfm}

{ TForm1 }

function TForm1.ConvertDateToString(Date: TDateTime): string;
var
  year,month,day : word;
  th, hn, tn, un       : word;
begin
  DecodeDate(Date,year,month,day);
  // разбираем число
  tn := day div  10 ;
  un := day mod  10 ;
  if un =  0  then
    result := NamesOfTens00[tn]
  else if tn =  0  then
    result := NamesOfUnits0[un]
  else if tn =  1  then
    result := NamesOfFistTen0[un]
  else
    result := NamesOfTens[tn]+ ' '+ NamesOfUnits0[un];
  // разбираем месяц
  result := result + ' ' + MonthNames[month];
  // разбираем год
  th := year div  1000 ;
  hn := year mod  1000  div  100 ;
  tn := year mod  1000  mod  100  div  10 ;
  un := year mod  1000  mod  100  mod  10 ;
  if ((hn= 0 )and(tn =  0 )and(un =  0 )) then
   begin
    result := result + ' ' + NamesOfThousand0[th] + ' года';
    exit;
   end
  else
    result := result + ' ' +NamesOfThousand[th];
  if hn >  0  then
   begin
    if((tn =  0 )and(un =  0 )) then
      begin
        result := result + ' ' + NamesOfHandreds0[hn] + ' года';
        exit;
      end
    else
        result := result + ' ' + NamesOfHandreds[hn];
   end;
  if un =  0  then
    result := result + ' ' + NamesOfTens0[tn]
  else if tn =  0  then
    result := result + ' ' + NamesOfUnits[un]
  else if tn =  1  then
    result := result + ' ' + NamesOfFistTen[un]
  else
    result := result + ' ' + NamesOfTens[tn]+ ' '+ NamesOfUnits[un];
  result := result + ' года'
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  // тест
  Caption := DateToStr(now- 1280 )+' ' +ConvertDateToString(now- 1280 );
end;

end.