home *** CD-ROM | disk | FTP | other *** search
/ Chip 1999 January / Chip_1999-01_cd.bin / zkuste / delphi / D1 / PROGRESS.ZIP / PRGRSS.PAS < prev    next >
Pascal/Delphi Source File  |  1996-05-31  |  4KB  |  159 lines
  1. {   Progress Meter 1.0 copyright 1996    }
  2. { Mark Harwood - mark@temati.demon.co.uk }
  3.  
  4. unit Prgrss;
  5.  
  6. interface
  7.  
  8. uses
  9.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  10.   Forms, Dialogs, ExtCtrls;
  11.  
  12. type
  13.   TProgressStatus = (psOn, psOff, psNudge);
  14.  
  15. type
  16.   TMDHProgress = class(TCustomControl)
  17.   private
  18.     { Private declarations }
  19.     FProgressStatus: TProgressStatus;
  20.     FProgressActive: Boolean;
  21.     FProgressTimer: TTimer;
  22.     FProgressForeColor: TColor;
  23.     FProgressBackColor: TColor;
  24.     FProgressInterval: word;
  25.     FProgressCurrent: integer;
  26.     procedure SetProgressStatus(value: TProgressStatus);
  27.     procedure SetProgressInterval(value: word);
  28.     procedure SetProgressForeColor(value: TColor);
  29.     procedure SetProgressBackColor(value: TColor);
  30.     procedure DrawStripe(i: integer);
  31.   protected
  32.     NudgeCounter : word;
  33.     procedure Paint; override;
  34.     procedure TimerComplete(sender: TObject);
  35.   public
  36.     constructor Create(AOwner: TComponent); override;
  37.     destructor Destroy; override;
  38.     procedure Nudge;
  39.   published
  40.     property ForeColor: TColor read FProgressForeColor write SetProgressForeColor default clBlue;
  41.     property BackColor: TColor read FProgressBackColor write SetProgressBackColor default clRed;
  42.     property Status: TProgressStatus read FProgressStatus write SetProgressStatus default psOff;
  43.     property Interval: word read FProgressInterval write SetProgressInterval default 100;
  44.   end;
  45.  
  46. procedure Register;
  47.  
  48. implementation
  49.  
  50. procedure Register;
  51. begin
  52.   RegisterComponents('Marks', [TMDHProgress]);
  53. end;
  54.  
  55. constructor TMDHProgress.Create(AOwner: TComponent);
  56. begin
  57.   inherited Create(AOwner);
  58.   { set defaults }
  59.   Width:=150;
  60.   Height:=14;
  61.   FProgressForeColor:=clBlue;
  62.   FProgressBackColor:=clRed;
  63.   FProgressInterval:=100;
  64.   FProgressStatus:=psOff;
  65.   NudgeCounter:=0;
  66. end;
  67.  
  68. destructor TMDHProgress.Destroy;
  69. begin
  70.   if assigned(FProgressTimer) then FProgressTimer.Free;
  71.   inherited Destroy;
  72. end;
  73.  
  74. procedure TMDHProgress.DrawStripe(i: integer);
  75. begin
  76.   Canvas.Polygon([Point (i - Height, 1), Point(i, 1),
  77.                   Point (i - Height, Height - 1), Point(i - (Height * 2), Height - 1)]);
  78. end;
  79.  
  80. procedure TMDHProgress.Paint;
  81. var
  82.   x : integer;
  83. begin
  84. with Canvas do
  85. begin
  86.   Brush.Color:=FProgressBackColor;
  87.   Rectangle (0, 0, Width, Height);
  88.   Brush.Color:=FProgressForeColor;
  89.   Pen.Color:=FProgressForeColor;
  90.   for x:=0 to (Width + Height) do
  91.   begin
  92.     if x mod (Height * 2)  = 0 then DrawStripe(x + FProgressCurrent);
  93.   end; { for }
  94. end; { with }
  95. end;
  96.  
  97. procedure TMDHProgress.SetProgressForeColor(value: TColor);
  98. begin
  99.   FProgressForeColor:= value;
  100.   invalidate;
  101. end;
  102.  
  103. procedure TMDHProgress.SetProgressBackColor(value: TColor);
  104. begin
  105.   FProgressBackColor:= value;
  106.   invalidate
  107. end;
  108.  
  109. procedure TMDHProgress.SetProgressStatus(value: TProgressStatus);
  110. begin
  111.   if value <> FProgressStatus then
  112.   begin
  113.     if assigned(FProgressTimer) then
  114.     begin
  115.       FProgressTimer.Free;
  116.       FProgressTimer:=nil;
  117.     end;
  118.     FProgressStatus:=value;
  119.     if FProgressStatus = psOn then
  120.     begin
  121.       FProgressTimer:=TTimer.Create(Self);
  122.       FProgressTimer.Interval:=FProgressInterval;
  123.       FProgressTimer.OnTimer:=TimerComplete;
  124.     end;
  125.     if FProgressStatus = psNudge then NudgeCounter:=0;
  126.   end;
  127. end;
  128.  
  129. procedure TMDHProgress.SetProgressInterval(value: word);
  130. begin
  131.   if value <> FProgressInterval then
  132.   begin
  133.     FProgressInterval:=value;
  134.     if assigned(FProgressTimer) then FProgressTimer.Interval:=FProgressInterval;
  135.   end;
  136. end;
  137.  
  138. procedure TMDHProgress.TimerComplete(sender: TObject);
  139. var
  140.   x: integer;
  141. begin
  142.   FProgressCurrent:=FProgressCurrent + 5;
  143.   if FProgressCurrent >= (Height * 2) then FProgressCurrent:=0;
  144.   invalidate;
  145. end;
  146.  
  147. procedure TMDHProgress.Nudge;
  148. begin
  149.   if FProgressStatus<>psNudge then exit;
  150.   inc (NudgeCounter);
  151.   if NudgeCounter>FProgressInterval then
  152.   begin
  153.     TimerComplete (Self);
  154.     NudgeCounter:=0;
  155.   end;
  156. end;
  157.  
  158. end.
  159.