home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 September / Chip_2002-09_cd1.bin / zkuste / delphi / kompon / d123456 / STR_BIT.ZIP / 16 / LINPR / PASTOOLS.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  2000-04-26  |  8.0 KB  |  223 lines
  1. unit Pastools;  { ¼«ñπ½∞ «Γ«ípáªÑ¡¿∩ ΓѬπΘÑú« óδ»«½¡Ñ¡¿∩ »p«úpá¼¼δ }
  2.                      { (æ) æѼѡ«ó é.ï. 1997 }
  3. {$F+}
  4. interface
  5. uses Dos, App, Objects, Drivers, Views;
  6.  
  7. const
  8.  rlRunningLine = $01; { ö½áú óδñáτ¿ íÑúπΘÑ⌐ ßΓp«¬¿ }
  9.  rlMaxCount    = $02; { ö½áú óδñáτ¿ ¼á¬ß¿¼á½∞¡«ú« º¡áτÑ¡¿∩ »ÑpѼѡ¡«⌐ µ¿¬½á }
  10.  rlCurrCount   = $04; { ö½áú óδñáτ¿ ΓѬπΘÑú« º¡áτÑ¡¿∩ »ÑpѼѡ¡«⌐ µ¿¬½á }
  11.  rlPercent     = $08; { ö½áú óδñáτ¿ ñ«½¿ »p«ΦÑñΦÑ⌐ «ípáí«Γ¬¿ }
  12.  rlExecTime    = $10; { ö½áú óδñáτ¿ ópѼѡ¿ «ípáí«Γ¬¿ }
  13.  rlMemAvail    = $20; { ö½áú óδñáτ¿ pẼÑpá ßó«í«ñ¡«⌐ »á¼∩Γ¿ }
  14.  rlFullInf     = $3F; { ö½áú óδñáτ¿ óßÑσ ß««íΘÑ¡¿⌐ }
  15. (*---------------------------------------------------------------------}
  16. { { Åα¿¼Ñα ¿ß»«½∞º«óá¡¿∩ ¼«ñπ½∩ }                                      }
  17. { uses Pastools, StrBit16, ...                                         }
  18. {                          ...                                         }
  19. { var Xod_vyp : PRunningLine;  { ÄíΩѬΓ, «Γ«íαáªáεΘ¿⌐ σ«ñ óδ»«½¡Ñ¡¿∩ } }
  20. {     is_file : PBitFile;              { êßσ«ñ¡δ⌐ í¿Γ«óδ⌐ »«Γ«¬ }      }
  21. {                          ...                                         }
  22. { begin                                                                }
  23. {                          ...                                         }
  24. { is_file := New(PBitFile,Init(1,4096));   { ÄΓ¬αδΓ∞ í¿Γ«óδ⌐ Σá⌐½ }    }
  25. { is_file^.OpenBitFile('aa.txt',btOpenRead);                           }
  26. { { éδóÑßΓ¿ »½«ßπ »α«úαÑßßá óδ»«½¡Ñ¡¿∩ «»Ñαᵿ¿ }                      }
  27. { New(Xod_vyp,Init(' ', is_file^.SizeOfFile,rlFullInf));               }
  28. {                          ...                                         }
  29. { while is_file^.ReadStr(200) = btOK do begin                          }
  30. {   Xod_vyp^.StatusDisplay(is_file^.NomTekBi); { Äí¡«ó¿Γ∞ ß«ßΓ«∩¡¿Ñ }  }
  31. {                          ...                                         }
  32. {    end;                                                              }
  33. {                          ...                                         }
  34. {  Dispose(Xod_vyp,Done);  { ôñ὿Γ∞ »«½«ßπ »α«úαÑßßá }                }
  35. {  is_file^.CloseBitFile;                                              }
  36. {  Dispose(is_file,Done);                                              }
  37. {---------------------------------------------------------------------*)
  38. type
  39.   PRunningLine = ^TRunningLine;
  40.   TRunningLine = object(TWindow)
  41.    constructor Init(ATitle: string; MaxCount : Longint; AOptions:byte);
  42.    constructor InitRect(R:Trect; ATitle: string;
  43.                         MaxCount : Longint; AOptions:byte);
  44.    procedure StatusDisplay(CurrCount :Longint);
  45.        private
  46.             PInterior : PView;
  47.    end;
  48.   PMemoryTest = ^TMemoryTest;
  49.   TMemoryTest = object  { »p«óÑp¬á «ßó«í«ªñÑ¡¿∩ ÄÅ }
  50.    constructor Init(ATitle: string);
  51.    destructor Done;
  52.    procedure ErrDisplay(Size:Longint);
  53.        private
  54.             MemAvailStart : Longint;
  55.             ident         : string[8];
  56.    end;
  57.  
  58. implementation
  59.  
  60. type
  61.   PRunningLineInterior = ^TRunningLineInterior;
  62.   TRunningLineInterior = object(TView)
  63.    constructor Init(RBounds:Trect; MaxCount : Longint; AOptions:byte);
  64.    procedure Draw; virtual;
  65.    procedure SetCurrentCount (CurrCount : Longint);
  66.        private
  67.             rlOptions     : byte;
  68.             CurrentCount  : Longint;
  69.             MaximumCount  : Longint;
  70.             Time          : Longint; { ó ßѬπ¡ñáσ }
  71.    end;
  72.  
  73. { -------  TRunningLine  ------------ }
  74. constructor TRunningLine.Init(ATitle: string;
  75.                         MaxCount : Longint; AOptions:byte);
  76. var
  77.    R    : Trect;
  78.    nr,i : byte;
  79. begin
  80.    nr := 0;
  81.    for i := 0 to 5 do
  82.        if (AOptions AND ($0001 shl i)) <> 0 then inc(nr);
  83.    i := Length(ATitle);
  84.    if i < 22 then i := 32  else inc(i,10);
  85.    R.Assign(0,0,i,nr+3);
  86.    R.Move((Desktop^.Size.X-R.B.X) div 2,(Desktop^.Size.Y-R.B.Y) div 2);
  87.    InitRect(R,ATitle,MaxCount, AOptions);
  88. end;   { TRunningLine.Init }
  89.  
  90. constructor TRunningLine.InitRect(R:Trect; ATitle: string;
  91.                         MaxCount : Longint; AOptions:byte);
  92. begin
  93.     TWindow.Init(R,ATitle,wnNoNumber);
  94.     Options := Options and (NOT ofSelectable);
  95.     GetExtent(R);
  96.     R.Grow(-1,-1);
  97.     PInterior := New(PRunningLineInterior,Init(R,MaxCount, AOptions));
  98.     Insert(PInterior);
  99.     DeskTop^.Insert(@Self);
  100. end;   { TRunningLine.InitRect }
  101.  
  102. procedure TRunningLine.StatusDisplay(CurrCount :Longint);
  103. var
  104.     pRL : PRunningLineInterior absolute PInterior;
  105. begin
  106.     pRL^.SetCurrentCount(CurrCount);
  107.     pRL^.DrawView;
  108. end;   { TRunningLine.StatusDisplay }
  109.  
  110. { -------  TRunningLineInterior  ------------ }
  111. constructor TRunningLineInterior.Init(RBounds:Trect;
  112.               MaxCount : Longint; AOptions:byte);
  113. var h,m,s,s100 : word;
  114. begin
  115.     TView.Init(RBounds);
  116.     rlOptions     := AOptions;
  117.     CurrentCount  := 0;
  118.     MaximumCount  := Abs(MaxCount);
  119.     GetTime(h,m,s,s100);
  120.     Time          :=  h * 60 + m;
  121.     Time          :=  Time * 60 + s;
  122. end;   { TRunningLineInterior.Init }
  123.  
  124. procedure TRunningLineInterior.Draw;
  125. var cs : string;
  126.  
  127. procedure FillTime;
  128. var h,m,s,s100 : word;
  129.     et         : Longint;
  130.     Param      : record h,m,s : Longint; end;
  131. begin
  132.     GetTime(h,m,s,s100);
  133.     et := h * 60 + m;
  134.     et := et * 60 + s - Time;
  135.     if et < 0 then Inc(et,24*60*60);
  136.     With param do begin
  137.        S := et mod 60;
  138.        M := (et div 60) mod 60;
  139.        H := et div 3600;
  140.                   end;
  141.     FormatStr(cs,'%02d:%02d:%02d',Param);
  142.     cs := '   épѼ∩       :' + cs;
  143. end;
  144.  
  145. procedure CountToLine(Count:longint;ATitle:string);
  146. begin
  147.    Str(Count:8,cs);
  148.    Cs := ' '+ ATitle + ':' + Cs;
  149. end;
  150.  
  151. const
  152.    rlFirstLine = $80;
  153.    rlMass : array [0..6] of byte =
  154.               ( rlFirstLine, rlRunningLine, rlMaxCount, rlCurrCount,
  155.                 rlPercent, rlExecTime, rlMemAvail);
  156. var Percent,i,QCols : byte;
  157.     VProc           : real;
  158.     Color           : word;
  159.     nr              : integer;
  160.     B               : TDrawBuffer;
  161. begin
  162.     if MaximumCount = 0 then Percent := 0
  163.                         else begin
  164.                    VProc := CurrentCount;
  165.                    VProc := VProc * 100 / MaximumCount;
  166.                    Percent := Trunc(VProc);
  167.                              end;
  168.     qCols := Percent * (Size.X-2) div 100;
  169.     Color := GetColor(1);
  170.     nr    := -1;
  171.     for i := 0 to 6 do begin
  172.         cs := '';
  173.         case ((rlOptions OR rlFirstLine) AND rlMass[i]) of
  174.              rlFirstLine   : cs := ' ';
  175.              rlRunningLine : begin
  176.                        while Length(cs) < qCols do Cs := Cs + #219;
  177.                        while Length(cs) < Size.X-2 do Cs := Cs + #177;
  178.                        cs := ' ' + cs + ' ';
  179.                              end;
  180.              rlMaxCount    : CountToLine(MaximumCount,'  éßÑú«       ');
  181.              rlCurrCount   : CountToLine(CurrentCount,'  Äípáí«Γá¡«  ');
  182.              rlPercent     : CountToLine(Percent     ,'  %           ');
  183.              rlExecTime    : FillTime;
  184.              rlMemAvail    : begin
  185.                        Str((MemAvail div 1024):3,cs);
  186.                        cs := ' æó«í«ñ¡á∩ »á¼∩Γ∞: '+ cs +' èí'
  187.                              end
  188.         end;  { Case }
  189.         if Length(cs) <> 0 then begin
  190.                 inc(nr); While Length(cs) < Size.X do Cs := Cs + ' ';
  191.                 MoveStr(B,cs,Color);  WriteLine(0,nr,Size.X,1,B)
  192.                                 end;
  193.     end  { µ¿¬½á }
  194. end;   { TRunningLineInterior.Draw; }
  195.  
  196. procedure TRunningLineInterior.SetCurrentCount (CurrCount : Longint);
  197. begin
  198.     CurrentCount := Abs(CurrCount) mod ( MaximumCount + 1 )
  199. end;   { TRunningLineInterior.SetCurrentCount }
  200.  
  201. { ----------  TMemoryTest  -------------- }
  202.  
  203. constructor TMemoryTest.Init(ATitle: string);
  204. begin
  205.     MemAvailStart := MemAvail;
  206.     ident         := ATitle;
  207. end;
  208.  
  209. destructor TMemoryTest.Done;
  210. var i : longint;
  211. begin
  212.     i := MemAvailStart - MemAvail;
  213.     if i <> 0 then ErrDisplay(i);
  214. end;
  215.  
  216. procedure TMemoryTest.ErrDisplay(Size:Longint);
  217. begin
  218.     WriteLn(Ident + ': ¡Ñ «ßó«í«ªñÑ¡á ÄÅ pẼÑp«¼ (ó íá⌐Γáσ) = ',Size);
  219.     WriteLn('ì᪼¿ΓÑ "Enter"');
  220.     Readln;
  221. end;
  222.  
  223. end.