Arsip: Komponen --> Progress Bar

unit ProBar;
{ - Created by Hasan - }
{ - 11-08-1998 - }

{$R-,T-,H+,X+}
interface
uses Windows, Messages, SysUtils, Controls, Classes, Graphics, Forms;
TProgress = Class(TCustomControl)
private
FStep: Real;
FBarMax, FBarPos: Integer;
FBarColor: TColor;
FStepIt: Boolean;
procedure SetBarMax(Value: Integer);
procedure SetBarPos(Value: Integer);
procedure SetBarColor(Value: TColor);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure StepIt;
procedure Paint; override;
procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
published
property Color;
property Font;
property BarColor: TColor read FBarColor write SetBarColor;
property BarMax: Integer read FBarMax write SetBarMax;
property BarPos: Integer read FBarPos write SetBarPos;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Hasan', [TProgress] );
end;
( -------------- TProgress -------------  )
( --------------------------------------  )
constructor TProgress.Create(AOwner: TComponent);
begin
inherited Create( AOwner );
ParentFont  := False;
ParentColor := False;
BevelInner  := bvLowered;
BevelKind   := bkTile;
FBarColor   := clBlue;
FBarMax := 100;
FBarPos := 0;
FStepIt := False;
end;
destructor TProgress.Destroy;
begin
inherited Destroy;
end;
procedure TProgress.WMEraseBkgnd(var Message: TWmEraseBkgnd);
var R: TRect;
begin
if Canvas<>nil then begin
R := ClientRect;
if FStepIt then begin
R.Left := (R.Right div 2) + 20;
R.Right := round(FBarPos  FStep);
if (R.Right <= R.Left) then begin
R.Left  := R.Left - 40;
R.Right := R.Left + 40;
Canvas.Brush.Color := Color;
Canvas.FillRect( R );
end;
end else begin
Canvas.Brush.Color := Color;
Canvas.FillRect( R );
if (csDesigning in ComponentState) then Paint;
end;
end;
Message.Result := 1;
end;
procedure TProgress.SetBarColor(Value: TColor);
begin
if FBarColor <> Value then begin
FBarColor := Value;
Invalidate;
end;
end;
procedure TProgress.SetBarMax(Value: Integer);
begin
if FBarMax <> Value then begin
if (Value>0) then begin
FBarMax := Value;
if FBarPos > FBarMax then FBarPos := FBarMax;
Invalidate;
end;
end;
end;
procedure TProgress.SetBarPos(Value: Integer);
begin
if FBarPos <> Value then begin
if (Value>=0) and (Value<=FBarMax) then begin
FStepIt := False;
FBarPos := Value;
Refresh;
end;
end;
end;
procedure TProgress.StepIt;
begin
if FBarPos < FBarMax then begin
FStepIt := True;
inc(FBarPos);
Refresh;
end;
end;
procedure TProgress.Paint;
var R: TRect;
cPersen: String;
begin
FStep := (ClientWidth / FBarMax);
R := ClientRect;
R.Left  := 0;
R.Right := round(FBarPos   FStep);
Canvas.Brush.Color := FBarColor;
Canvas.FillRect( R );
R.Left := 1;
R.Right := ClientWidth-1;
Canvas.Font := Font;
Canvas.Brush.Style := bsClear;
cPersen := IntToStr( round((FBarPos * 100) / FBarMax) ) + '%';
R.Top := ((R.Bottom - Canvas.TextHeight(cPersen)) div 2);
R.Bottom := R.Top + Canvas.TextHeight( cPersen );
DrawText( Canvas.Handle, pChar(cPersen), -1, R, DT_CENTER );
end;
end.