From 3b94b13c57ff8708e58fae63c4d9035a7269e525 Mon Sep 17 00:00:00 2001 From: wp_xxyyzz Date: Wed, 29 Mar 2023 17:20:29 +0000 Subject: [PATCH] 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 --- .../exctrls/examples/ProgressBarEx/main.lfm | 139 ++++++++++++++---- .../exctrls/examples/ProgressBarEx/main.pas | 29 +++- components/exctrls/source/exprogressbar.pas | 128 ++++++++++++++-- 3 files changed, 251 insertions(+), 45 deletions(-) diff --git a/components/exctrls/examples/ProgressBarEx/main.lfm b/components/exctrls/examples/ProgressBarEx/main.lfm index 54307ac56..d0b7fa081 100644 --- a/components/exctrls/examples/ProgressBarEx/main.lfm +++ b/components/exctrls/examples/ProgressBarEx/main.lfm @@ -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 diff --git a/components/exctrls/examples/ProgressBarEx/main.pas b/components/exctrls/examples/ProgressBarEx/main.pas index 4584debf8..81a62954a 100644 --- a/components/exctrls/examples/ProgressBarEx/main.pas +++ b/components/exctrls/examples/ProgressBarEx/main.pas @@ -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; diff --git a/components/exctrls/source/exprogressbar.pas b/components/exctrls/source/exprogressbar.pas index 4a52fbe89..660593ed2 100644 --- a/components/exctrls/source/exprogressbar.pas +++ b/components/exctrls/source/exprogressbar.pas @@ -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);