home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: Multimed / Multimed.zip / mp3osr05.zip / src / gadgets.pas < prev    next >
Pascal/Delphi Source File  |  1999-12-05  |  4KB  |  206 lines
  1. {************************************************}
  2. {                                                }
  3. {   Turbo Vision Demo                            }
  4. {   Copyright (c) 1992 by Borland International  }
  5. {                                                }
  6. {************************************************}
  7. { additions were made by FreePascal development team }
  8.  
  9. unit Gadgets;
  10.  
  11. {
  12.   Useful gadgets: clock and heap available viewer
  13. }
  14.  
  15. {$F+,O+,E+,N+}
  16. {$X+,R-,I-,Q-,V-}
  17.  
  18. interface
  19.  
  20. uses Dos, Objects, Views, App;
  21.  
  22. type
  23.   THeapViewMode = (HVNormal, HVComma, HVKb, HVMb);
  24.  
  25.   PHeapView = ^THeapView;
  26.   THeapView = object(TView)
  27.     Mode: THeapViewMode;
  28.     OldMem: LongInt;
  29.     constructor Init(var Bounds: TRect);
  30.     constructor InitComma(var Bounds: TRect);
  31.     constructor InitKb(var Bounds: TRect);
  32.     constructor InitMb(var Bounds: TRect);
  33.     procedure Draw; virtual;
  34.     procedure Update;
  35.     function Comma(N: LongInt): string;
  36.   end;
  37.  
  38.   PClockView = ^TClockView;
  39.   TClockView = object(TView)
  40.     am: Char;
  41.     Refresh: Byte;
  42.     LastTime: DateTime;
  43.     TimeStr: string[10];
  44.     constructor Init(var Bounds: TRect);
  45.     procedure Draw; virtual;
  46.     function FormatTimeStr(H, M, S: Word): string; virtual;
  47.     procedure Update; virtual;
  48.   end;
  49.  
  50.  
  51. implementation
  52.  
  53. uses Drivers;
  54.  
  55. {*****************************************************************************
  56.                                      HeapView
  57. *****************************************************************************}
  58.  
  59. constructor THeapView.Init(var Bounds: TRect);
  60. begin
  61.   inherited Init(Bounds);
  62.   mode := HVNormal;
  63.   OldMem := 0;
  64. end;
  65.  
  66. constructor THeapView.InitComma(var Bounds: TRect);
  67. begin
  68.   inherited Init(Bounds);
  69.   mode := HVComma;
  70.   OldMem := 0;
  71. end;
  72.  
  73. constructor THeapView.InitKb(var Bounds: TRect);
  74. begin
  75.   inherited Init(Bounds);
  76.   mode := HVKb;
  77.   OldMem := 0;
  78. end;
  79.  
  80. constructor THeapView.InitMb(var Bounds: TRect);
  81. begin
  82.   inherited Init(Bounds);
  83.   mode := HVMb;
  84.   OldMem := 0;
  85. end;
  86.  
  87. procedure THeapView.Draw;
  88. var
  89.   S: string;
  90.   B: TDrawBuffer;
  91.   C: Byte;
  92. begin
  93.   OldMem := MemAvail;
  94.   case mode of
  95.     HVNormal:
  96.       Str(OldMem: Size.X, S);
  97.     HVComma:
  98.       S := Comma(OldMem);
  99.     HVKb:
  100.       begin
  101.         Str(OldMem shr 10: Size.X - 1, S);
  102.         S := S + 'K';
  103.       end;
  104.     HVMb:
  105.       begin
  106.         Str(OldMem shr 20: Size.X - 1, S);
  107.         S := S + 'M';
  108.       end;
  109.   end;
  110.   C := GetColor(2);
  111.   MoveChar(B, ' ', C, Size.X);
  112.   MoveStr(B, S, C);
  113.   WriteLine(0, 0, Size.X, 1, B);
  114. end;
  115.  
  116.  
  117. procedure THeapView.Update;
  118. begin
  119.   if (OldMem <> MemAvail) then DrawView;
  120. end;
  121.  
  122.  
  123. function THeapView.Comma(n: LongInt): string;
  124. var
  125.   num, loc: Byte;
  126.   s: string;
  127.   t: string;
  128. begin
  129.   Str(n, s);
  130.   Str(n: Size.X, t);
  131.  
  132.   num := length(s) div 3;
  133.   if (length(s) mod 3) = 0 then dec(num);
  134.  
  135.   delete(t, 1, num);
  136.   loc := length(t) - 2;
  137.  
  138.   while num > 0 do
  139.   begin
  140.     Insert(',', t, loc);
  141.     dec(num);
  142.     dec(loc, 3);
  143.   end;
  144.  
  145.   Comma := t;
  146. end;
  147.  
  148.  
  149. {*****************************************************************************
  150.                                      ClockView
  151. *****************************************************************************}
  152.  
  153. function LeadingZero(w: Word): string;
  154. var
  155.   s: string;
  156. begin
  157.   Str(w: 0, s);
  158.   LeadingZero := Copy('00', 1, 2 - Length(s)) + s;
  159. end;
  160.  
  161. constructor TClockView.Init(var Bounds: TRect);
  162. begin
  163.   inherited Init(Bounds);
  164.   FillChar(LastTime, SizeOf(LastTime), #$FF);
  165.   TimeStr := '';
  166.   Refresh := 1;
  167. end;
  168.  
  169.  
  170. procedure TClockView.Draw;
  171. var
  172.   B: TDrawBuffer;
  173.   C: Byte;
  174. begin
  175.   C := GetColor(2);
  176.   MoveChar(B, ' ', C, Size.X);
  177.   MoveStr(B, TimeStr, C);
  178.   WriteLine(0, 0, Size.X, 1, B);
  179. end;
  180.  
  181.  
  182. procedure TClockView.Update;
  183. var
  184.   h, m, s, hund: {$IFNDEF virtualpascal}word{$ELSE}longint{$ENDIF};
  185. begin
  186.   GetTime(h, m, s, hund);
  187.   if Abs(s - LastTime.sec) >= Refresh then
  188.   begin
  189.     with LastTime do
  190.     begin
  191.       Hour := h;
  192.       Min := m;
  193.       Sec := s;
  194.     end;
  195.     TimeStr := FormatTimeStr(h, m, s);
  196.     DrawView;
  197.   end;
  198. end;
  199.  
  200. function TClockView.FormatTimeStr(H, M, S: Word): string;
  201. begin
  202.   FormatTimeStr := LeadingZero(h) + ':' + LeadingZero(m) +
  203.     ':' + LeadingZero(s);
  204. end;
  205.  
  206. end.