307 lines
7.7 KiB
ObjectPascal
307 lines
7.7 KiB
ObjectPascal
unit mckCProgBar;
|
|
|
|
interface
|
|
|
|
uses
|
|
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
|
|
ComCtrls, ExtCtrls, mirror;
|
|
|
|
type
|
|
|
|
TBevel = (bvUp, bvDown, bvNone);
|
|
|
|
TColorProgressBar = class(TKOLControl)
|
|
private
|
|
{ Private declarations }
|
|
fPosition: integer;
|
|
fOldPosit: integer;
|
|
fBColor,
|
|
fFColor : TColor;
|
|
fFirst : boolean;
|
|
fBorder : integer;
|
|
fParentCl: boolean;
|
|
// fBrush : boolean;
|
|
fBevel : TBevel;
|
|
fMin,
|
|
fMax : integer;
|
|
fStr : string;
|
|
procedure SetFColor(C: TColor);
|
|
procedure SetBColor(C: TColor);
|
|
procedure SetPosition(P: integer);
|
|
procedure SetBorder(B: integer);
|
|
procedure SetParentCl(B: boolean);
|
|
procedure SetBevel(B: TBevel);
|
|
procedure SetMin(M: integer);
|
|
procedure SetMax(M: integer);
|
|
protected
|
|
{ Protected declarations }
|
|
procedure Paint;
|
|
procedure WMPaint(var Msg: TMessage); message WM_PAINT;
|
|
procedure WMSize (var Msg: TMessage); message WM_SIZE;
|
|
procedure WMActiv(var Msg: TMessage); message WM_SHOWWINDOW;
|
|
procedure CMParCl(var Msg: TMessage); message CM_PARENTCOLORCHANGED;
|
|
function AdditionalUnits: string; override;
|
|
procedure SetupFirst( SL: TStringList; const AName, AParent, Prefix: String ); override;
|
|
public
|
|
{ Public declarations }
|
|
constructor Create(Owner: TComponent); override;
|
|
published
|
|
{ Published declarations }
|
|
property FColor: TColor read fFColor write SetFColor;
|
|
property BColor: TColor read fBColor write SetBColor;
|
|
property Border: integer read fBorder write SetBorder;
|
|
property Position: integer read fPosition write SetPosition;
|
|
property Max: integer read fMax write SetMax;
|
|
property Min: integer read fMin write SetMin;
|
|
property ParentColor: boolean read fParentCl write SetParentCl;
|
|
property Bevel: TBevel read fBevel write SetBevel;
|
|
{ property Font;}
|
|
end;
|
|
|
|
procedure Register;
|
|
|
|
implementation
|
|
|
|
{$R *.dcr}
|
|
|
|
procedure Register;
|
|
begin
|
|
RegisterComponents('KOLAddons', [TColorProgressBar]);
|
|
end;
|
|
|
|
constructor TColorProgressBar.Create;
|
|
begin
|
|
inherited;
|
|
fBColor := ClBtnFace;
|
|
fFColor := ClRed;
|
|
Width := 100;
|
|
Height := 30;
|
|
fFirst := True;
|
|
fBorder := 4;
|
|
fPosition := 50;
|
|
fMin := 0;
|
|
fMax := 100;
|
|
Font.FontHeight := -17;
|
|
Font.FontStyle := [fsBold];
|
|
end;
|
|
|
|
procedure TColorProgressBar.WMPaint;
|
|
begin
|
|
inherited;
|
|
Paint;
|
|
end;
|
|
|
|
procedure TColorProgressBar.WMSize;
|
|
begin
|
|
inherited;
|
|
fFirst := True;
|
|
Paint;
|
|
end;
|
|
|
|
procedure TColorProgressBar.WMActiv;
|
|
begin
|
|
inherited;
|
|
fFirst := True;
|
|
Paint;
|
|
end;
|
|
|
|
procedure TColorProgressBar.CMParCl;
|
|
begin
|
|
inherited;
|
|
if fParentCl then begin
|
|
if Msg.wParam <> 0 then
|
|
BColor := TColor(Msg.lParam) else
|
|
BColor := (Parent as TForm).Color;
|
|
FColor := (Parent as TForm).Font.Color;
|
|
end;
|
|
end;
|
|
|
|
function TColorProgressBar.AdditionalUnits;
|
|
begin
|
|
Result := ', KOLProgBar';
|
|
end;
|
|
|
|
procedure TColorProgressBar.SetupFirst;
|
|
var St: string;
|
|
begin
|
|
inherited;
|
|
if fPosition <> 50 then begin
|
|
SL.Add( Prefix + AName + '.Position := ' + inttostr(fPosition) + ';');
|
|
end;
|
|
if fBorder <> 4 then begin
|
|
SL.Add( Prefix + AName + '.Border := ' + inttostr(fBorder) + ';');
|
|
end;
|
|
if fMin <> 0 then begin
|
|
SL.Add( Prefix + AName + '.Min := ' + inttostr(fMin) + ';');
|
|
end;
|
|
if fMax <> 100 then begin
|
|
SL.Add( Prefix + AName + '.Max := ' + inttostr(fMax) + ';');
|
|
end;
|
|
if fFColor <> clRed then begin
|
|
SL.Add( Prefix + AName + '.FColor := ' + color2str(fFColor) + ';');
|
|
end;
|
|
if fBColor <> clRed then begin
|
|
SL.Add( Prefix + AName + '.BColor := ' + color2str(fBColor) + ';');
|
|
end;
|
|
if fBevel <> bvDown then begin
|
|
if fBevel = bvUp then St := 'bvUp' else St := 'bvNone';
|
|
SL.Add( Prefix + AName + '.Bevel := ' + St + ';');
|
|
end;
|
|
end;
|
|
|
|
procedure TColorProgressBar.SetFColor;
|
|
begin
|
|
fFColor := C;
|
|
fFirst := True;
|
|
Paint;
|
|
end;
|
|
|
|
procedure TColorProgressBar.SetBColor;
|
|
begin
|
|
fBColor := C;
|
|
fFirst := True;
|
|
Paint;
|
|
end;
|
|
|
|
procedure TColorProgressBar.SetPosition;
|
|
begin
|
|
fPosition := P;
|
|
Paint;
|
|
end;
|
|
|
|
procedure TColorProgressBar.SetBorder;
|
|
begin
|
|
fBorder := B;
|
|
fFirst := True;
|
|
Paint;
|
|
end;
|
|
|
|
procedure TColorProgressBar.SetParentCl;
|
|
begin
|
|
fParentCl := B;
|
|
if B then begin
|
|
Perform(CM_PARENTCOLORCHANGED, 0, 0);
|
|
Paint;
|
|
end;
|
|
end;
|
|
|
|
procedure TColorProgressBar.SetBevel;
|
|
begin
|
|
fBevel := B;
|
|
fFirst := True;
|
|
Paint;
|
|
end;
|
|
|
|
procedure TColorProgressBar.SetMin;
|
|
begin
|
|
fMin := M;
|
|
fFirst := True;
|
|
if fMax = fMin then fMax := fMin + 1;
|
|
Paint;
|
|
end;
|
|
|
|
procedure TColorProgressBar.SetMax;
|
|
begin
|
|
fMax := M;
|
|
fFirst := True;
|
|
if fMin = fMax then fMin := fMax - 1;
|
|
Paint;
|
|
end;
|
|
|
|
procedure TColorProgressBar.Paint;
|
|
var Rct: TRect;
|
|
Trc: TRect;
|
|
Twk: TRect;
|
|
Str: string;
|
|
Rht: integer;
|
|
Len: integer;
|
|
Rgn: HRgn;
|
|
begin
|
|
Rct := GetClientRect;
|
|
Trc := Rct;
|
|
if (fPosition <= fOldPosit) or fFirst or
|
|
(csDesigning in ComponentState) then begin
|
|
case fBevel of
|
|
bvUp: begin
|
|
Frame3D(Canvas, Rct, clWhite, clBlack, 1);
|
|
end;
|
|
bvDown: begin
|
|
Frame3D(Canvas, Rct, clBlack, clWhite, 1);
|
|
end;
|
|
end;
|
|
|
|
fFirst := False;
|
|
Canvas.brush.Color := fBColor;
|
|
Canvas.FillRect(Rct);
|
|
end;
|
|
Rct := Trc;
|
|
|
|
InflateRect(Rct, -fBorder, -fBorder);
|
|
Rct.Right := Rct.Left + (Rct.Right - Rct.Left) * fPosition div (Max - Min);
|
|
|
|
Str := ' ' + inttostr(fPosition * 100 div (fMax - fMin)) + '% ';
|
|
Trc.Left := (width - Canvas.TextWidth(Str)) div 2;
|
|
Trc.Right := (width + Canvas.TextWidth(Str)) div 2 + 1;
|
|
|
|
if (Rct.Right <= Trc.Left) then begin
|
|
Canvas.brush.Color := fFColor;
|
|
Canvas.FillRect(Rct);
|
|
end else begin
|
|
Canvas.brush.Color := fFColor;
|
|
Twk := Rct;
|
|
Twk.Right := Trc.Left;
|
|
Canvas.FillRect(Twk);
|
|
end;
|
|
|
|
Rht := Rct.Right;
|
|
Canvas.Font.Name := Font.FontName;
|
|
Canvas.Font.Height := Font.FontHeight;
|
|
Canvas.Font.Color := Font.Color;
|
|
Canvas.Font.Style := Font.FontStyle;
|
|
Len := Length(Str);
|
|
Rct.Left := (width - Canvas.TextWidth(Str)) div 2;
|
|
Rct.Right := (width + Canvas.TextWidth(Str)) div 2 + 1;
|
|
|
|
if (fStr <> Str) or ffirst or (csDesigning in ComponentState) then begin
|
|
if (Rct.Right > Rht) or (Canvas.TextHeight(Str) > (Rct.Bottom - Rct.Top)) then begin
|
|
Rgn := CreateRectRgn({Left +} Rht, {Top +} Rct.Top, {Left +} Rct.Right, {Top +} Rct.Bottom);
|
|
SelectClipRgn(Canvas.Handle, Rgn);
|
|
Canvas.brush.Color := fBColor;
|
|
SetTextColor(Canvas.Handle, ColorToRGB(fFColor));
|
|
DrawText(Canvas.Handle, @Str[1], Len, Rct, DT_TOP {or DT_NOCLIP});
|
|
SelectClipRgn(Canvas.Handle, 0);
|
|
DeleteObject(Rgn);
|
|
end;
|
|
end;
|
|
|
|
if Rht < Rct.Right then begin
|
|
Rct.Right := Rht;
|
|
end;
|
|
|
|
Dec(Rct.Left);
|
|
Inc(Rct.Right);
|
|
|
|
if (Rct.Right > Rct.Left) then begin
|
|
Canvas.brush.Color := fFColor;
|
|
SetTextColor(Canvas.Handle, ColorToRGB(fBColor));
|
|
DrawText(Canvas.Handle, @Str[1], Len, Rct, DT_TOP);
|
|
if Rct.Right < Trc.Right then begin
|
|
Twk := Rct;
|
|
Twk.Top := Twk.Top + Canvas.TextHeight(Str);
|
|
Canvas.Fillrect(Twk);
|
|
end;
|
|
end;
|
|
|
|
if (Rct.Right >= Trc.Right) then begin
|
|
Canvas.brush.Color := fFColor;
|
|
Rct.Left := Trc.Right - 1;
|
|
Rct.Right := Rht;
|
|
Canvas.FillRect(Rct);
|
|
end;
|
|
|
|
fStr := Str;
|
|
fOldPosit := fPosition;
|
|
end;
|
|
|
|
end.
|