Hallo Leute,
ich habe eine Fremdkomponente mit Source und habe sie mir
entsprechend umgebaut.
Ich dachte nicht das es so Problemlos ist.
Herlichen Dank an alle.
Gruß Kostas
unit Progbr3d;
interface
{$A+} { Word align data }
{$B-} { Complete Boolean Evaluation Directive }
{$D-} { Debug Information Directive }
{$L-} { Local Symbol Information Directive }
{$R-} { Range checking off }
{$S-} { Stack checking off }
{$T-} { We don't need (nor want) this type checking! }
uses
WinTypes, WinProcs, Classes, Graphics, Controls, ExtCtrls, Forms,
SysUtils, Dialogs;
type
ProgressBar3DOrientation = (BarHorizontal, BarVertical);
ProgressBar3D = class(TCustomPanel)
private
{ Private declarations }
FProgress : Double;
FMinValue : Double;
FMaxValue : Double;
FShowText : Boolean;
FBackColor : TColor;
FBarColor : TColor;
FBorderColor: TColor;
FOrientation: ProgressBar3DOrientation;
FHeight : Integer;
FWidth : Integer;
FValueChange: TNotifyEvent;
FPrefix : String;
FNachkomma : Integer;
procedure SetBounds(Left,Top,fWidth,fHeight: integer); override;
procedure SetHeight(Value: Integer); virtual;
procedure SetWidth(Value: Integer); virtual;
procedure SetNachkomma(Value: Integer); virtual;
procedure SetMaxValue(Value: Double); virtual;
procedure SetMinValue(Value: Double); virtual;
procedure SetProgress(Value: Double); virtual;
{}procedure SetPrefix(Value: String); virtual;
procedure SetOrientation(Value: ProgressBar3DOrientation);
procedure SetShowText(Value: Boolean);
procedure SetBackColor(Value: TColor);
procedure SetBarColor(Value: TColor);
procedure SetBorderColor(Value: TColor);
function GetPercentDone: Double;
protected
{ Protected declarations }
procedure Paint; override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure AddProgress(Value: Double);
procedure SetMinMaxValue(MinValue,MaxValue: Double);
published
{ Published declarations }
property PercentDone: Double read GetPercentDone;
property Align;
property Cursor;
property Enabled;
property Font;
property Height default 25;
property Width default 100;
property Prefix: String read FPrefix write SetPrefix;
property Nachkomma: Integer read FNachkomma write SetNachkomma default 0;
property MaxValue: Double read FMaxValue write SetMaxValue;
property MinValue: Double read FMinValue write SetMinValue;
property Progress: Double read FProgress write SetProgress;
property ShowText: Boolean read FShowText write SetShowText default True;
property BarColor: TColor read FBarColor write SetBarColor default clBtnFace;
property BackColor: TColor read FBackColor write SetBackColor default clBtnFace;
property BorderColor: TColor read FBorderColor write SetBorderColor default clBtnFace;
property Orientation: ProgressBar3DOrientation read FOrientation write SetOrientation default BarHorizontal;
property OnValueChange: TNotifyEvent read FValueChange write FValueChange;
property Visible;
property Hint;
property ParentFont;
property ParentShowHint;
property ShowHint;
property Tag;
property OnClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
end;
procedure Register;
implementation
constructor ProgressBar3D.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FBackColor := clBtnFace;
FBarColor := clBtnFace;
FBorderColor := clBtnFace;
Height := 25;
Width := 100;
FOrientation := BarHorizontal;
Font.Color := clBlue;
Caption := ' ';
FMinValue := 0;
FMaxValue := 100;
FProgress := 0;
FShowText := True;
FPrefix := '';
FNachkomma := 0;
end;
destructor ProgressBar3D.Destroy;
begin
inherited Destroy;
end;
procedure ProgressBar3D.SetBackColor(Value: TColor);
begin
FBackColor := Value;
Invalidate;
end;
procedure ProgressBar3D.SetBorderColor(Value: TColor);
begin
FBorderColor := Value;
Invalidate;
end;
procedure ProgressBar3D.SetBarColor(Value: TColor);
begin
FBarColor := Value;
Invalidate;
end;
procedure ProgressBar3D.SetHeight(Value: integer);
begin
if Value <> fHeight then
begin
FHeight:= Value;
SetBounds(Left, Top, Width, FHeight);
Invalidate;
end
end;
procedure ProgressBar3D.SetWidth(Value: integer);
begin
if Value <> fWidth then
begin
FWidth:= Value;
SetBounds(Left, Top, FWidth, Height);
Invalidate;
end
end;
procedure ProgressBar3D.SetBounds(Left, Top, FWidth, FHeight: Integer);
{-------------------------------------------}
procedure SwapWH(Var Width, Height: Integer);
var
TmpInt: Integer;
begin
TmpInt:= Width;
Width := Height;
Height:= TmpInt;
end;
{-------------------------------------------}
procedure SetMinDims(var XValue, YValue: Integer; XValueMin, YValueMin: Integer);
begin
if XValue < XValueMin
then XValue:= XValueMin;
if YValue < YValueMin
then YValue:= YValueMin;
end;
{-------------------------------------------}
begin
case fOrientation of
BarHorizontal:
begin
if FHeight > FWidth then SwapWH(FWidth, FHeight);
SetMinDims(FWidth, FHeight, 50, 20);
end;
BarVertical:
begin
if FWidth > FHeight then SwapWH(FWidth, FHeight);
SetMinDims(fWidth,fHeight,20,50);
end;
end; { Case }
inherited SetBounds(Left, Top, FWidth, FHeight);
end;
procedure ProgressBar3D.SetOrientation(Value: ProgressBar3DOrientation);
var
x: Integer;
begin
if Value <> FOrientation then
begin
FOrientation := Value;
SetBounds(Left, Top, Height, Width);
Invalidate;
end
end;
procedure ProgressBar3D.SetMaxValue(Value: Double);
begin
if Value <> FMaxValue then
begin
FMaxValue := Value;
Invalidate;
end
end;
{}procedure ProgressBar3D.SetPrefix(Value: String);
begin
if Value <> FPrefix then
begin
FPrefix := Value;
Invalidate;
end
end;
{}procedure ProgressBar3D.SetNachkomma(Value: Integer);
begin
if Value <> Fnachkomma then
begin
Fnachkomma := Value;
Invalidate;
end
end;
procedure ProgressBar3D.SetMinValue(Value: Double);
begin
if Value <> FMinValue then
begin
FMinValue := Value;
Invalidate;
end
end;
procedure ProgressBar3D.SetMinMaxValue(MinValue, MaxValue: Double);
begin
FMinValue := MinValue;
FMaxValue := MaxValue;
FProgress := 0;
Repaint;
end;
{ This function solves for x in the equation "x is y% of z". }
function SolveForX(Y, Z: Double): Double;
begin
SolveForX := (Z * (Y * 0.01));
end;
{ This function solves for y in the equation "x is y% of z". }
function SolveForY(X, Z: Double): Double;
begin
if Z = 0 then SolveForY := 0
else SolveForY := ((X * 100) / Z);
end;
function ProgressBar3D.GetPercentDone: Double;
begin
GetPercentDone := SolveForY(FProgress - FMinValue, FMaxValue - FMinValue);
end;
procedure ProgressBar3D.Paint;
var
TheImage: TBitmap;
FillSize: Longint;
W, H, X, Y : Integer;
TheText: string;
begin
with Canvas do
begin
TheImage:= TBitmap.Create;
Try
TheImage.Height:= Height;
TheImage.Width := Width;
with TheImage.Canvas do
begin
Brush.Color:= FBorderColor;
with ClientRect do
begin
Pen.Style:= psSolid;
Pen.Width:= 1;
Pen.Color:= clBlack;
Rectangle(Left,Top,Right,Bottom);
Pen.Color:= clGray;
Brush.Color:= FBackColor;
// Rectangle(Left + 3, Top + 3, Right - 3, Bottom - 3); kostas
Rectangle(Left, Top, Right, Bottom);
Pen.Color:= clWhite;
MoveTo(Left, Bottom);
LineTo(Right, Bottom);
LineTo(Right, Top);
// MoveTo(Left + 4, Bottom - 4); kostas
// LineTo(Right - 4, Bottom - 4);
// LineTo(Right - 4, Top + 2);
Pen.Color:= clBlack;
if Orientation = BarHorizontal then w:= Right - Left { + 1; }
else w:= Bottom - Top;
FillSize:= Trunc(SolveForX(PercentDone, W));
if FillSize > 0 then
begin
Brush.Color:= FBarColor;
case orientation of
BarHorizontal:
begin
Rectangle(Left,Top,FillSize,Bottom);
{ Draw the 3D Percent stuff }
{ UpperRight, LowerRight, LowerLeft }
Pen.Color:= clGray;
Pen.Width:= 1;
MoveTo(FillSize, Top);
LineTo(FillSize, Bottom);
// Pen.Width:= 2; kostas
// MoveTo(FillSize - 2, Top + 2);
// LineTo(FillSize - 2, Bottom - 2);
LineTo(Left, Bottom);
{ LowerLeft, UpperLeft, UpperRight }
Pen.Color:= clWhite;
Pen.Width:= 1;
MoveTo(Left, Bottom);
LineTo(Left, Top);
LineTo(FillSize, Top);
// LineTo(Left + 2, Bottom - 2); kostas
// { LowerLeft, UpperLeft, UpperRight }
// Pen.Color:= clWhite;
// Pen.Width:= 1;
// MoveTo(Left + 1, Bottom - 3);
// LineTo(Left + 1, Top + 1);
// LineTo(FillSize - 2, Top + 1);
end;
BarVertical:
begin
FillSize:= Height - FillSize;
Rectangle(Left,FillSize,Right,Bottom);
{ Draw the 3D Percent stuff }
{ LowerLeft, UpperLeft, UpperRight }
Pen.Color:= clGray;
Pen.Width:= 2;
MoveTo(Left + 2, FillSize + 2);
LineTo(Right - 2, FillSize + 2);
LineTo(Right - 2, Bottom - 2);
{ UpperRight, LowerRight, LowerLeft }
Pen.Color:= clWhite;
Pen.Width:= 1;
MoveTo(Left + 1,FillSize + 2);
LineTo(Left + 1,Bottom - 2);
LineTo(Right - 2,Bottom - 2);
end;
end; { Case }
end;
if ShowText then
begin
Brush.Style := bsClear;
Font := Self.Font;
Font.Color := Self.Font.Color;
TheText:= FPrefix + Format('%*.*f%%', [8, FNachkomma, (PercentDone)]);
X:= (Right - Left + 1 - TextWidth(TheText)) div 2;
Y:= (Bottom - Top + 1 - TextHeight(TheText)) div 2;
TextRect(ClientRect, X, Y, TheText);
end;
end;
end;
Canvas.CopyMode:= cmSrcCopy;
Canvas.Draw(0,0,TheImage);
Finally
TheImage.Destroy;
End; { Try }
end; { With }
end;
procedure ProgressBar3D.SetProgress(Value: Double);
begin
if (FProgress <> Value) and (Value >= FMinValue) and (Value <= FMaxValue) then
begin
FProgress:= Value;
Invalidate;
end
end;
procedure ProgressBar3D.AddProgress(Value: Double);
begin
Progress:= fProgress + Value;
Refresh;
end;
procedure ProgressBar3D.SetShowText(Value: Boolean);
begin
if Value <> FShowText then
begin
FShowText:= Value;
Refresh;
end
end;
procedure Register;
begin
RegisterComponents('kostas', [ProgressBar3D]);
end;
end.