ExCtrls/TProgressBarEx: Add border styles, AutoSize, improved captions.

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@8782 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2023-03-29 17:20:29 +00:00
parent e67b015e3f
commit 3b94b13c57
3 changed files with 251 additions and 45 deletions

View File

@ -1,26 +1,28 @@
object Form1: TForm1
Left = 261
Height = 465
Height = 567
Top = 130
Width = 473
Caption = 'TProgressBarEx Demo'
ClientHeight = 465
ClientHeight = 567
ClientWidth = 473
OnCreate = FormCreate
LCLVersion = '2.3.0.0'
object GroupBox1: TGroupBox
Left = 105
Height = 160
Top = 112
Left = 106
Height = 136
Top = 88
Width = 347
Caption = 'Style'
ClientHeight = 140
ClientHeight = 116
ClientWidth = 343
TabOrder = 0
object rbNormalStyle: TRadioButton
AnchorSideTop.Control = ScrollBar1
AnchorSideTop.Side = asrCenter
Left = 20
Height = 19
Top = 9
Top = 3
Width = 86
Caption = 'Normal Style'
Checked = True
@ -29,28 +31,35 @@ object Form1: TForm1
TabStop = True
end
object rbMarqueeStyle: TRadioButton
AnchorSideTop.Control = Edit1
AnchorSideTop.Side = asrCenter
Left = 20
Height = 19
Top = 45
Top = 31
Width = 93
Caption = 'Marquee Style'
OnChange = rbMarqueeStyleChange
TabOrder = 0
end
object ScrollBar1: TScrollBar
AnchorSideTop.Control = GroupBox1
Left = 136
Height = 17
Top = 11
Top = 4
Width = 201
BorderSpacing.Top = 4
PageSize = 0
TabOrder = 2
OnChange = ScrollBar1Change
end
object Edit1: TEdit
AnchorSideTop.Control = ScrollBar1
AnchorSideTop.Side = asrBottom
Left = 136
Height = 23
Top = 45
Top = 29
Width = 201
BorderSpacing.Top = 8
OnChange = Edit1Change
TabOrder = 3
Text = 'Some text...'
@ -60,16 +69,19 @@ object Form1: TForm1
AnchorSideTop.Side = asrCenter
Left = 136
Height = 15
Top = 76
Top = 62
Width = 84
Caption = 'Marquee length'
end
object seMarqueeLength: TSpinEdit
AnchorSideTop.Control = rbMarqueeStyle
AnchorSideTop.Side = asrBottom
Left = 240
Height = 23
Top = 72
Top = 58
Width = 50
Alignment = taRightJustify
BorderSpacing.Top = 8
OnChange = seMarqueeLengthChange
TabOrder = 4
Value = 120
@ -79,25 +91,28 @@ object Form1: TForm1
AnchorSideTop.Side = asrCenter
Left = 139
Height = 15
Top = 108
Top = 89
Width = 81
Caption = 'Marquee speed'
end
object seMarqueeSpeed: TSpinEdit
AnchorSideTop.Control = seMarqueeLength
AnchorSideTop.Side = asrBottom
Left = 240
Height = 23
Top = 104
Top = 85
Width = 50
Alignment = taRightJustify
BorderSpacing.Top = 4
OnChange = seMarqueeSpeedChange
TabOrder = 5
Value = 8
end
end
object btnFont: TButton
Left = 304
Left = 310
Height = 25
Top = 416
Top = 344
Width = 75
Caption = 'Font'
OnClick = btnFontClick
@ -112,9 +127,9 @@ object Form1: TForm1
Visible = False
end
object clbBackColor: TColorButton
Left = 298
Left = 305
Height = 25
Top = 296
Top = 232
Width = 146
BorderWidth = 2
ButtonColorAutoSize = False
@ -125,9 +140,9 @@ object Form1: TForm1
OnColorChanged = clbBackColorColorChanged
end
object clbBarColor: TColorButton
Left = 297
Left = 304
Height = 25
Top = 323
Top = 259
Width = 146
BorderWidth = 2
ButtonColorAutoSize = False
@ -138,9 +153,9 @@ object Form1: TForm1
OnColorChanged = clbBarColorColorChanged
end
object clbGradientEndColor: TColorButton
Left = 297
Left = 304
Height = 25
Top = 351
Top = 287
Width = 146
BorderWidth = 2
ButtonColorAutoSize = False
@ -151,9 +166,9 @@ object Form1: TForm1
OnColorChanged = clbGradientEndColorColorChanged
end
object clbBorderColor: TColorButton
Left = 297
Left = 304
Height = 25
Top = 379
Top = 315
Width = 146
BorderWidth = 2
ButtonColorAutoSize = False
@ -166,16 +181,16 @@ object Form1: TForm1
object CheckBox1: TCheckBox
Left = 105
Height = 19
Top = 80
Top = 64
Width = 164
Caption = 'Compare with TProgressBar'
OnChange = CheckBox1Change
TabOrder = 3
end
object rgOrientation: TRadioGroup
Left = 104
Left = 105
Height = 64
Top = 280
Top = 232
Width = 190
AutoFill = True
Caption = 'Orientation'
@ -200,9 +215,9 @@ object Form1: TForm1
TabOrder = 4
end
object rgDrawingStyle: TRadioGroup
Left = 104
Left = 105
Height = 81
Top = 360
Top = 304
Width = 185
AutoFill = True
Caption = 'Drawing style'
@ -227,10 +242,74 @@ object Form1: TForm1
OnClick = rgDrawingStyleClick
TabOrder = 5
end
object RadioGroup1: TRadioGroup
Left = 105
Height = 64
Top = 392
Width = 185
AutoFill = True
Caption = 'Caption'
ChildSizing.LeftRightSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 2
ClientHeight = 44
ClientWidth = 181
Columns = 2
ItemIndex = 0
Items.Strings = (
'None'
'Position'
'Percentage'
'Custom text'
)
OnClick = RadioGroup1Click
TabOrder = 6
end
object RadioGroup2: TRadioGroup
Left = 304
Height = 80
Top = 376
Width = 140
AutoFill = True
Caption = 'Border'
ChildSizing.LeftRightSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 2
ClientHeight = 60
ClientWidth = 136
Columns = 2
ItemIndex = 1
Items.Strings = (
'None'
'Flat'
'Sunken'
'Raised'
'Etched'
)
OnClick = RadioGroup2Click
TabOrder = 7
end
object Button1: TButton
Left = 355
Height = 25
Top = 61
Width = 75
Caption = 'AutoSize'
OnClick = Button1Click
TabOrder = 8
end
object FontDialog1: TFontDialog
MinFontSize = 0
MaxFontSize = 0
Left = 408
Top = 408
Top = 344
end
end

View File

@ -14,6 +14,7 @@ type
TForm1 = class(TForm)
btnFont: TButton;
Button1: TButton;
CheckBox1: TCheckBox;
clbBackColor: TColorButton;
clbBarColor: TColorButton;
@ -25,6 +26,8 @@ type
lblMarqueeLength: TLabel;
lblMarqueeSpeed: TLabel;
ProgressBar1: TProgressBar;
RadioGroup1: TRadioGroup;
RadioGroup2: TRadioGroup;
rbNormalStyle: TRadioButton;
rbMarqueeStyle: TRadioButton;
rgOrientation: TRadioGroup;
@ -33,6 +36,7 @@ type
seMarqueeLength: TSpinEdit;
seMarqueeSpeed: TSpinEdit;
procedure btnFontClick(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure CheckBox1Change(Sender: TObject);
procedure clbBackColorColorChanged(Sender: TObject);
procedure clbBarColorColorChanged(Sender: TObject);
@ -40,6 +44,8 @@ type
procedure clbBorderColorColorChanged(Sender: TObject);
procedure Edit1Change(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure RadioGroup1Click(Sender: TObject);
procedure RadioGroup2Click(Sender: TObject);
procedure rbNormalStyleChange(Sender: TObject);
procedure rbMarqueeStyleChange(Sender: TObject);
procedure rgDrawingStyleClick(Sender: TObject);
@ -69,6 +75,7 @@ begin
ProgressbarEx.Left := 8;
ProgressbarEx.Top := 8;
ProgressbarEx.Width := 450;
ProgressbarEx.Height := 32;
ProgressbarEx.Parent := self;
Progressbarex.Position := 75;
@ -87,6 +94,21 @@ begin
Height := Width;
end;
procedure TForm1.RadioGroup1Click(Sender: TObject);
begin
ProgressBarEx.TextMode := TProgressbarTextMode(RadioGroup1.ItemIndex);
case ProgressBarEx.TextMode of
tmValue: ProgressBarEx.Caption := 'Voltage: %.0f mV';
tmPercent: ProgressBarEx.Caption := '%.1f%% complete';
tmCustom: ProgressBarEx.Caption := Edit1.Text;
end;
end;
procedure TForm1.RadioGroup2Click(Sender: TObject);
begin
ProgressBarEx.BorderStyle := TProgressBarBorderStyle(RadioGroup2.ItemIndex);
end;
procedure TForm1.rbNormalStyleChange(Sender: TObject);
begin
Progressbar1.style := pbstNormal;
@ -141,6 +163,11 @@ begin
ProgressbarEx.Font := FontDialog1.Font;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ProgressbarEx.AutoSize := true;
end;
procedure TForm1.CheckBox1Change(Sender: TObject);
begin
Progressbar1.Visible := Checkbox1.Checked;
@ -169,8 +196,6 @@ end;
procedure TForm1.ScrollBar1Change(Sender: TObject);
begin
ProgressbarEx.Position := Scrollbar1.Position;
ProgressbarEx.Caption := IntToStr(Scrollbar1.Position);
Progressbar1.Position := Scrollbar1.Position;
end;

View File

@ -5,10 +5,13 @@ unit ExProgressbar;
interface
uses
Classes, SysUtils, Graphics, Types, Controls, ExtCtrls, ComCtrls;
LCLIntf, LCLType, Classes, SysUtils, Graphics, Types, Controls,
ExtCtrls, ComCtrls;
type
TProgressBarBorderStyle = (bsNone, bsFlat, bsSunken, bsRaised, bsEtched);
TProgressbarDrawStyle = (pdsFlat, pdsGradient, pdsRounded, pdsShiny, pdsBevel);
TProgressbarTextMode = (tmNone, tmValue, tmPercent, tmCustom);
TProgressbarEx = class(TGraphicControl)
private
@ -20,9 +23,10 @@ type
DEFAULT_MARQUEELENGTH = 120;
DEFAULT_MARQUEESPEED = 8;
private
FBorderStyle: TProgressBarBorderStyle;
FCaption: String;
FColors: array[0..3] of TColor;
FDrawStyle: TProgressbarDrawStyle;
FDrawStyle: TProgressBarDrawStyle;
FMarqueePosition: Integer;
FMarqueeLength: Integer;
FMarqueeSpeed: Integer;
@ -31,8 +35,10 @@ type
FOrientation: TProgressBarOrientation; // (pbHorizontal, pbVertical, pbRightToLeft, pbTopDown)
FPosition: Integer;
FStyle: TProgressBarStyle; // (pbstNormal, pbstMarquee)
FTextMode: TProgressBarTextMode;
FTimer: TTimer;
function GetColors(AIndex: Integer): TColor;
procedure SetBorderStyle(AValue: TProgressBarBorderStyle);
procedure SetCaption(AValue: String);
procedure SetColors(AIndex: Integer; AValue: TColor);
procedure SetDrawStyle(AValue: TProgressbarDrawStyle);
@ -41,6 +47,7 @@ type
procedure SetOrientation(AValue: TProgressbarOrientation);
procedure SetPosition(AValue: Integer);
procedure SetStyle(AValue: TProgressbarStyle);
procedure SetTextMode(AValue: TProgressBarTextMode);
procedure TimerHandler(Sender: TObject);
protected
procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
@ -49,11 +56,13 @@ type
class function GetControlClassDefaultSize: TSize; override;
function IsHorizontal(AOrientation: TProgressbarOrientation): Boolean;
procedure Paint; override;
procedure SetAutoSize(AValue: Boolean); override;
public
constructor Create(AOwner: TComponent); override;
published
property BackColor: TColor index 0 read GetColors write SetColors default DEFAULT_BACKCOLOR;
property BorderColor: TColor index 1 read GetColors write SetColors default DEFAULT_BORDERCOLOR;
property BorderStyle: TProgressbarBorderStyle read FBorderSTyle write SetBorderStyle default bsFlat;
property BarColor: TColor index 2 read GetColors write SetColors default DEFAULT_BARCOLOR;
property GradientEndColor: TColor index 3 read GetColors write SetColors default DEFAULT_GRADIENTENDCOLOR;
property Caption: String read FCaption write SetCaption;
@ -65,9 +74,11 @@ type
property Orientation: TProgressbarOrientation read FOrientation write SetOrientation default pbHorizontal;
property Position: Integer read FPosition write SetPosition default 0;
property Style: TProgressbarStyle read FStyle write SetStyle default pbstNormal;
property TextMode: TProgressBarTextMode read FTextMode write SetTextMode default tmNone;
property Align;
property Anchors;
property AutoSize;
property BorderSpacing;
property Constraints;
property Font;
@ -90,6 +101,8 @@ begin
inherited;
ControlStyle := ControlStyle - [csSetCaption];
FBorderStyle := bsFlat;
FCaption := '';
FColors[0] := DEFAULT_BACKCOLOR;
FColors[1] := DEFAULT_BORDERCOLOR;
@ -121,7 +134,12 @@ function TProgressBarEx.GetBarRect: TRect;
var
fraction: Double;
begin
Result := Rect(1, 1, Width-1, Height-1);
Result := Rect(0, 0, Width, Height);
case FBorderStyle of
bsNone: ;
bsEtched: InflateRect(Result, -2, -2);
else InflateRect(Result, -1, -1);
end;
fraction := (FPosition - FMin) / (FMax - FMin);
case FStyle of
pbstNormal:
@ -129,10 +147,10 @@ begin
if FMax = FMin then
exit(Rect(0, 0, 0, 0));
case FOrientation of
pbHorizontal: Result.Right := round(fraction * (Width - 2));
pbRightToLeft: Result.Left := Result.Right - round(fraction * (Width - 2));
pbVertical: Result.Top := Result.Bottom - round(fraction * (Height - 2));
pbTopDown: Result.Bottom := round(fraction * (Height - 2));
pbHorizontal: Result.Right := round(fraction * (Width - 1));
pbRightToLeft: Result.Left := Result.Right - round(fraction * (Width - 1));
pbVertical: Result.Top := Result.Bottom - round(fraction * (Height - 1));
pbTopDown: Result.Bottom := round(fraction * (Height - 1));
end;
end;
pbstMarquee:
@ -190,6 +208,8 @@ procedure TProgressbarEx.Paint;
var
R, R1, R2: TRect;
FontAngle: Integer;
posValue: Double;
txt: String;
txtSize: TSize;
isHor: Boolean;
col1, col2, col3: TColor;
@ -199,8 +219,30 @@ begin
// Draw background with border
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Color := BackColor;
Canvas.Pen.Color := BorderColor;
Canvas.Rectangle(0, 0, Width, Height);
R := Rect(0, 0, Width, Height);
if FBorderStyle = bsNone then
Canvas.FillRect(R)
else
if FBorderStyle = bsFlat then
begin
Canvas.Pen.Color := BorderColor;
Canvas.Rectangle(R);
end else
begin
case FBorderStyle of
bsSunken:
DrawEdge(Canvas.Handle, R, BDR_SUNKENOUTER, BF_RECT);
bsRaised:
DrawEdge(Canvas.Handle, R, BDR_RAISEDINNER, BF_RECT);
bsEtched:
begin
DrawEdge(Canvas.Handle, R, EDGE_ETCHED, BF_RECT);
InflateRect(R, -1, -1);
end;
end;
InflateRect(R, -1, -1);
Canvas.FillRect(R);
end;
// Draw bar
R := GetBarRect;
@ -298,22 +340,74 @@ begin
end;
// Draw text
if FCaption <> '' then
if FTextMode <> tmNone then
begin
txtSize := Canvas.TextExtent(FCaption);
case FTextMode of
tmValue:
if FCaption = '' then
txt := IntToStr(FPosition)
else
txt := Format(FCaption, [1.0*FPosition]);
tmPercent:
if FMax <> FMin then
begin
posValue := (FPosition - FMin) / (FMax - FMin) * 100.0;
if (FCaption = '') then
txt := Format('%.1f%%', [posValue])
else
txt := Format(FCaption, [posValue]);
end else
exit;
tmCustom:
txt := FCaption;
end;
txtSize := Canvas.TextExtent(txt);
Canvas.Font.Assign(Font);
Canvas.Font.Orientation := fontAngle;
Canvas.Brush.Style := bsClear;
R := Rect(0, 0, Width, Height);
if isHor then
Canvas.TextOut((Width - txtSize.CX) div 2, (Height - txtSize.CY) div 2, FCaption)
Canvas.TextOut((Width - txtSize.CX) div 2, (Height - txtSize.CY) div 2, txt)
else
Canvas.TextOut((Width - txtSize.CY) div 2, R.Bottom - (Height - txtSize.CX) div 2, FCaption);
Canvas.TextOut((Width - txtSize.CY) div 2, R.Bottom - (Height - txtSize.CX) div 2, txt);
end;
inherited;
end;
procedure TProgressBarEx.SetAutoSize(AValue: Boolean);
var
bmp: TBitmap;
fh: Integer;
begin
inherited;
if AutoSize then
begin
bmp := TBitmap.Create;
try
bmp.SetSize(1, 1);
bmp.Canvas.Font.Assign(Font);
fh := bmp.Canvas.TextHeight('Tg');
finally
bmp.Free;
end;
inc(fh, 8);
if IsHorizontal(FOrientation) then
Height := fh
else
Width := fh;
Invalidate;
end;
end;
procedure TProgressBarEx.SetBorderStyle(AValue: TProgressBarBorderStyle);
begin
if FBorderStyle = AValue then
exit;
FBorderStyle := AValue;
Invalidate;
end;
procedure TProgressbarEx.SetCaption(AValue: String);
begin
if FCaption = AValue then
@ -400,6 +494,14 @@ begin
end;
end;
procedure TProgressBarEx.SetTextMode(AValue: TProgressBarTextMode);
begin
if FTextMode = AValue then
exit;
FTextMode := AValue;
Invalidate;
end;
procedure TProgressbarEx.TimerHandler(Sender: TObject);
begin
inc(FMarqueePosition, FMarqueeSpeed);