home *** CD-ROM | disk | FTP | other *** search
- { Progress Meter 1.0 copyright 1996 }
- { Mark Harwood - mark@temati.demon.co.uk }
-
- unit Prgrss;
-
- interface
-
- uses
- SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
- Forms, Dialogs, ExtCtrls;
-
- type
- TProgressStatus = (psOn, psOff, psNudge);
-
- type
- TMDHProgress = class(TCustomControl)
- private
- { Private declarations }
- FProgressStatus: TProgressStatus;
- FProgressActive: Boolean;
- FProgressTimer: TTimer;
- FProgressForeColor: TColor;
- FProgressBackColor: TColor;
- FProgressInterval: word;
- FProgressCurrent: integer;
- procedure SetProgressStatus(value: TProgressStatus);
- procedure SetProgressInterval(value: word);
- procedure SetProgressForeColor(value: TColor);
- procedure SetProgressBackColor(value: TColor);
- procedure DrawStripe(i: integer);
- protected
- NudgeCounter : word;
- procedure Paint; override;
- procedure TimerComplete(sender: TObject);
- public
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
- procedure Nudge;
- published
- property ForeColor: TColor read FProgressForeColor write SetProgressForeColor default clBlue;
- property BackColor: TColor read FProgressBackColor write SetProgressBackColor default clRed;
- property Status: TProgressStatus read FProgressStatus write SetProgressStatus default psOff;
- property Interval: word read FProgressInterval write SetProgressInterval default 100;
- end;
-
- procedure Register;
-
- implementation
-
- procedure Register;
- begin
- RegisterComponents('Marks', [TMDHProgress]);
- end;
-
- constructor TMDHProgress.Create(AOwner: TComponent);
- begin
- inherited Create(AOwner);
- { set defaults }
- Width:=150;
- Height:=14;
- FProgressForeColor:=clBlue;
- FProgressBackColor:=clRed;
- FProgressInterval:=100;
- FProgressStatus:=psOff;
- NudgeCounter:=0;
- end;
-
- destructor TMDHProgress.Destroy;
- begin
- if assigned(FProgressTimer) then FProgressTimer.Free;
- inherited Destroy;
- end;
-
- procedure TMDHProgress.DrawStripe(i: integer);
- begin
- Canvas.Polygon([Point (i - Height, 1), Point(i, 1),
- Point (i - Height, Height - 1), Point(i - (Height * 2), Height - 1)]);
- end;
-
- procedure TMDHProgress.Paint;
- var
- x : integer;
- begin
- with Canvas do
- begin
- Brush.Color:=FProgressBackColor;
- Rectangle (0, 0, Width, Height);
- Brush.Color:=FProgressForeColor;
- Pen.Color:=FProgressForeColor;
- for x:=0 to (Width + Height) do
- begin
- if x mod (Height * 2) = 0 then DrawStripe(x + FProgressCurrent);
- end; { for }
- end; { with }
- end;
-
- procedure TMDHProgress.SetProgressForeColor(value: TColor);
- begin
- FProgressForeColor:= value;
- invalidate;
- end;
-
- procedure TMDHProgress.SetProgressBackColor(value: TColor);
- begin
- FProgressBackColor:= value;
- invalidate
- end;
-
- procedure TMDHProgress.SetProgressStatus(value: TProgressStatus);
- begin
- if value <> FProgressStatus then
- begin
- if assigned(FProgressTimer) then
- begin
- FProgressTimer.Free;
- FProgressTimer:=nil;
- end;
- FProgressStatus:=value;
- if FProgressStatus = psOn then
- begin
- FProgressTimer:=TTimer.Create(Self);
- FProgressTimer.Interval:=FProgressInterval;
- FProgressTimer.OnTimer:=TimerComplete;
- end;
- if FProgressStatus = psNudge then NudgeCounter:=0;
- end;
- end;
-
- procedure TMDHProgress.SetProgressInterval(value: word);
- begin
- if value <> FProgressInterval then
- begin
- FProgressInterval:=value;
- if assigned(FProgressTimer) then FProgressTimer.Interval:=FProgressInterval;
- end;
- end;
-
- procedure TMDHProgress.TimerComplete(sender: TObject);
- var
- x: integer;
- begin
- FProgressCurrent:=FProgressCurrent + 5;
- if FProgressCurrent >= (Height * 2) then FProgressCurrent:=0;
- invalidate;
- end;
-
- procedure TMDHProgress.Nudge;
- begin
- if FProgressStatus<>psNudge then exit;
- inc (NudgeCounter);
- if NudgeCounter>FProgressInterval then
- begin
- TimerComplete (Self);
- NudgeCounter:=0;
- end;
- end;
-
- end.
-