ExCtrls: New component: TProgressBarEx (https://forum.lazarus.freepascal.org/index.php/topic,62848.0.html)

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@8779 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2023-03-29 11:23:17 +00:00
parent f0a6fa13dc
commit ef7c6a38ac
13 changed files with 964 additions and 3 deletions
--- a/components/exctrls/examples/ProgressBarEx/demo.lpi
+++ b/components/exctrls/examples/ProgressBarEx/demo.lpi
@ -0,0 +1,88 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="12"/>
+    <PathDelim Value="\"/>
+    <General>
+      <SessionStorage Value="InProjectDir"/>
+      <Title Value="demo"/>
+      <Scaled Value="True"/>
+      <ResourceType Value="res"/>
+      <UseXPManifest Value="True"/>
+      <XPManifest>
+        <DpiAware Value="True"/>
+      </XPManifest>
+      <Icon Value="0"/>
+    </General>
+    <BuildModes>
+      <Item Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+      <UseFileFilters Value="True"/>
+    </PublishOptions>
+    <RunParams>
+      <FormatVersion Value="2"/>
+    </RunParams>
+    <RequiredPackages>
+      <Item>
+        <PackageName Value="ExCtrlsPkg"/>
+      </Item>
+      <Item>
+        <PackageName Value="LCL"/>
+      </Item>
+    </RequiredPackages>
+    <Units>
+      <Unit>
+        <Filename Value="demo.lpr"/>
+        <IsPartOfProject Value="True"/>
+      </Unit>
+      <Unit>
+        <Filename Value="main.pas"/>
+        <IsPartOfProject Value="True"/>
+        <ComponentName Value="Form1"/>
+        <HasResources Value="True"/>
+        <ResourceBaseClass Value="Form"/>
+      </Unit>
+      <Unit>
+        <Filename Value="exprogressbar.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="ExProgressbar"/>
+      </Unit>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <PathDelim Value="\"/>
+    <Target>
+      <Filename Value="demo"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+    <Linking>
+      <Debugging>
+        <DebugInfoType Value="dsDwarf3"/>
+      </Debugging>
+      <Options>
+        <Win32>
+          <GraphicApplication Value="True"/>
+        </Win32>
+      </Options>
+    </Linking>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions>
+      <Item>
+        <Name Value="EAbort"/>
+      </Item>
+      <Item>
+        <Name Value="ECodetoolError"/>
+      </Item>
+      <Item>
+        <Name Value="EFOpenError"/>
+      </Item>
+    </Exceptions>
+  </Debugging>
+</CONFIG>
--- a/components/exctrls/examples/ProgressBarEx/demo.lpr
+++ b/components/exctrls/examples/ProgressBarEx/demo.lpr
@ -0,0 +1,25 @@
+program demo;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}
+  cthreads,
+  {$ENDIF}
+  {$IFDEF HASAMIGA}
+  athreads,
+  {$ENDIF}
+  Interfaces, // this includes the LCL widgetset
+  Forms, main, ExProgressbar
+  { you can add units after this };
+
+{$R *.res}
+
+begin
+  RequireDerivedFormResource:=True;
+  Application.Scaled:=True;
+  Application.Initialize;
+  Application.CreateForm(TForm1, Form1);
+  Application.Run;
+end.
+
--- a/components/exctrls/examples/ProgressBarEx/main.lfm
+++ b/components/exctrls/examples/ProgressBarEx/main.lfm
@ -0,0 +1,236 @@
+object Form1: TForm1
+  Left = 261
+  Height = 465
+  Top = 130
+  Width = 473
+  Caption = 'TProgressBarEx Demo'
+  ClientHeight = 465
+  ClientWidth = 473
+  OnCreate = FormCreate
+  LCLVersion = '2.3.0.0'
+  object GroupBox1: TGroupBox
+    Left = 105
+    Height = 160
+    Top = 112
+    Width = 347
+    Caption = 'Style'
+    ClientHeight = 140
+    ClientWidth = 343
+    TabOrder = 0
+    object rbNormalStyle: TRadioButton
+      Left = 20
+      Height = 19
+      Top = 9
+      Width = 86
+      Caption = 'Normal Style'
+      Checked = True
+      OnChange = rbNormalStyleChange
+      TabOrder = 1
+      TabStop = True
+    end
+    object rbMarqueeStyle: TRadioButton
+      Left = 20
+      Height = 19
+      Top = 45
+      Width = 93
+      Caption = 'Marquee Style'
+      OnChange = rbMarqueeStyleChange
+      TabOrder = 0
+    end
+    object ScrollBar1: TScrollBar
+      Left = 136
+      Height = 17
+      Top = 11
+      Width = 201
+      PageSize = 0
+      TabOrder = 2
+      OnChange = ScrollBar1Change
+    end
+    object Edit1: TEdit
+      Left = 136
+      Height = 23
+      Top = 45
+      Width = 201
+      OnChange = Edit1Change
+      TabOrder = 3
+      Text = 'Some text...'
+    end
+    object lblMarqueeLength: TLabel
+      AnchorSideTop.Control = seMarqueeLength
+      AnchorSideTop.Side = asrCenter
+      Left = 136
+      Height = 15
+      Top = 76
+      Width = 84
+      Caption = 'Marquee length'
+    end
+    object seMarqueeLength: TSpinEdit
+      Left = 240
+      Height = 23
+      Top = 72
+      Width = 50
+      Alignment = taRightJustify
+      OnChange = seMarqueeLengthChange
+      TabOrder = 4
+      Value = 120
+    end
+    object lblMarqueeSpeed: TLabel
+      AnchorSideTop.Control = seMarqueeSpeed
+      AnchorSideTop.Side = asrCenter
+      Left = 139
+      Height = 15
+      Top = 108
+      Width = 81
+      Caption = 'Marquee speed'
+    end
+    object seMarqueeSpeed: TSpinEdit
+      Left = 240
+      Height = 23
+      Top = 104
+      Width = 50
+      Alignment = taRightJustify
+      OnChange = seMarqueeSpeedChange
+      TabOrder = 5
+      Value = 8
+    end
+  end
+  object btnFont: TButton
+    Left = 304
+    Height = 25
+    Top = 416
+    Width = 75
+    Caption = 'Font'
+    OnClick = btnFontClick
+    TabOrder = 1
+  end
+  object ProgressBar1: TProgressBar
+    Left = 13
+    Height = 20
+    Top = 32
+    Width = 450
+    TabOrder = 2
+    Visible = False
+  end
+  object clbBackColor: TColorButton
+    Left = 298
+    Height = 25
+    Top = 296
+    Width = 146
+    BorderWidth = 2
+    ButtonColorAutoSize = False
+    ButtonColorSize = 16
+    ButtonColor = clBlack
+    Caption = 'Background color'
+    Margin = 4
+    OnColorChanged = clbBackColorColorChanged
+  end
+  object clbBarColor: TColorButton
+    Left = 297
+    Height = 25
+    Top = 323
+    Width = 146
+    BorderWidth = 2
+    ButtonColorAutoSize = False
+    ButtonColorSize = 16
+    ButtonColor = clBlack
+    Caption = 'Bar color'
+    Margin = 4
+    OnColorChanged = clbBarColorColorChanged
+  end
+  object clbGradientEndColor: TColorButton
+    Left = 297
+    Height = 25
+    Top = 351
+    Width = 146
+    BorderWidth = 2
+    ButtonColorAutoSize = False
+    ButtonColorSize = 16
+    ButtonColor = clBlack
+    Caption = 'Gradient end color'
+    Margin = 4
+    OnColorChanged = clbGradientEndColorColorChanged
+  end
+  object clbBorderColor: TColorButton
+    Left = 297
+    Height = 25
+    Top = 379
+    Width = 146
+    BorderWidth = 2
+    ButtonColorAutoSize = False
+    ButtonColorSize = 16
+    ButtonColor = clBlack
+    Caption = 'Border color'
+    Margin = 4
+    OnColorChanged = clbBorderColorColorChanged
+  end
+  object CheckBox1: TCheckBox
+    Left = 105
+    Height = 19
+    Top = 80
+    Width = 164
+    Caption = 'Compare with TProgressBar'
+    OnChange = CheckBox1Change
+    TabOrder = 3
+  end
+  object rgOrientation: TRadioGroup
+    Left = 104
+    Height = 64
+    Top = 280
+    Width = 190
+    AutoFill = True
+    Caption = 'Orientation'
+    ChildSizing.LeftRightSpacing = 6
+    ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
+    ChildSizing.EnlargeVertical = crsHomogenousChildResize
+    ChildSizing.ShrinkHorizontal = crsScaleChilds
+    ChildSizing.ShrinkVertical = crsScaleChilds
+    ChildSizing.Layout = cclLeftToRightThenTopToBottom
+    ChildSizing.ControlsPerLine = 2
+    ClientHeight = 44
+    ClientWidth = 186
+    Columns = 2
+    ItemIndex = 0
+    Items.Strings = (
+      'horizontal'
+      'vertical'
+      'right to left'
+      'top down'
+    )
+    OnClick = rgOrientationClick
+    TabOrder = 4
+  end
+  object rgDrawingStyle: TRadioGroup
+    Left = 104
+    Height = 81
+    Top = 360
+    Width = 185
+    AutoFill = True
+    Caption = 'Drawing style'
+    ChildSizing.LeftRightSpacing = 6
+    ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
+    ChildSizing.EnlargeVertical = crsHomogenousChildResize
+    ChildSizing.ShrinkHorizontal = crsScaleChilds
+    ChildSizing.ShrinkVertical = crsScaleChilds
+    ChildSizing.Layout = cclLeftToRightThenTopToBottom
+    ChildSizing.ControlsPerLine = 2
+    ClientHeight = 61
+    ClientWidth = 181
+    Columns = 2
+    ItemIndex = 0
+    Items.Strings = (
+      'flat'
+      'gradient'
+      'rounded'
+      'shiny'
+      'bevel'
+    )
+    OnClick = rgDrawingStyleClick
+    TabOrder = 5
+  end
+  object FontDialog1: TFontDialog
+    MinFontSize = 0
+    MaxFontSize = 0
+    Left = 408
+    Top = 408
+  end
+end
--- a/components/exctrls/examples/ProgressBarEx/main.pas
+++ b/components/exctrls/examples/ProgressBarEx/main.pas
@ -0,0 +1,188 @@
+unit main;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ComCtrls,
+  Spin, ExtCtrls, ExProgressbar;
+
+type
+
+  { TForm1 }
+
+  TForm1 = class(TForm)
+    btnFont: TButton;
+    CheckBox1: TCheckBox;
+    clbBackColor: TColorButton;
+    clbBarColor: TColorButton;
+    clbGradientEndColor: TColorButton;
+    clbBorderColor: TColorButton;
+    Edit1: TEdit;
+    FontDialog1: TFontDialog;
+    GroupBox1: TGroupBox;
+    lblMarqueeLength: TLabel;
+    lblMarqueeSpeed: TLabel;
+    ProgressBar1: TProgressBar;
+    rbNormalStyle: TRadioButton;
+    rbMarqueeStyle: TRadioButton;
+    rgOrientation: TRadioGroup;
+    rgDrawingStyle: TRadioGroup;
+    ScrollBar1: TScrollBar;
+    seMarqueeLength: TSpinEdit;
+    seMarqueeSpeed: TSpinEdit;
+    procedure btnFontClick(Sender: TObject);
+    procedure CheckBox1Change(Sender: TObject);
+    procedure clbBackColorColorChanged(Sender: TObject);
+    procedure clbBarColorColorChanged(Sender: TObject);
+    procedure clbGradientEndColorColorChanged(Sender: TObject);
+    procedure clbBorderColorColorChanged(Sender: TObject);
+    procedure Edit1Change(Sender: TObject);
+    procedure FormCreate(Sender: TObject);
+    procedure rbNormalStyleChange(Sender: TObject);
+    procedure rbMarqueeStyleChange(Sender: TObject);
+    procedure rgDrawingStyleClick(Sender: TObject);
+    procedure rgOrientationClick(Sender: TObject);
+    procedure ScrollBar1Change(Sender: TObject);
+    procedure seMarqueeLengthChange(Sender: TObject);
+    procedure seMarqueeSpeedChange(Sender: TObject);
+  private
+    ProgressbarEx: TProgressbarEx;
+
+  public
+
+  end;
+
+var
+  Form1: TForm1;
+
+implementation
+
+{$R *.lfm}
+
+{ TForm1 }
+
+procedure TForm1.FormCreate(Sender: TObject);
+begin
+  ProgressbarEx := TProgressbarEx.Create(self);
+  ProgressbarEx.Left := 8;
+  ProgressbarEx.Top := 8;
+  ProgressbarEx.Width := 450;
+  ProgressbarEx.Parent := self;
+  Progressbarex.Position := 75;
+
+  Progressbar1.Left := ProgressbarEx.Left;
+  Progressbar1.Width := ProgressbarEx.Width;
+
+  clbBackColor.ButtonColor := ProgressbarEx.BackColor;
+  clbBarColor.ButtonColor := ProgressbarEx.BarColor;
+  clbGradientEndColor.ButtonColor := ProgressbarEx.GradientEndColor;
+  clbBorderColor.ButtonColor := ProgressbarEx.BorderColor;
+
+  Scrollbar1.Position := ProgressbarEx.Position;
+  Edit1.Hide;
+
+  Width := ProgressbarEx.Width + 2*ProgressbarEx.Left;
+  Height := Width;
+end;
+
+procedure TForm1.rbNormalStyleChange(Sender: TObject);
+begin
+  Progressbar1.style := pbstNormal;
+  ProgressbarEx.Style := pbstNormal;
+  ProgressbarEx.Caption := IntToStr(ProgressbarEx.Position);
+  Scrollbar1.Position := ProgressbarEx.Position;
+  Scrollbar1.Show;
+  Edit1.Hide;
+end;
+
+procedure TForm1.rbMarqueeStyleChange(Sender: TObject);
+begin
+  Progressbar1.Style := pbstMarquee;
+  ProgressbarEx.Style := pbstMarquee;
+  ProgressbarEx.Caption := Edit1.Text;
+  Scrollbar1.Hide;
+  Edit1.Show;
+end;
+
+procedure TForm1.rgDrawingStyleClick(Sender: TObject);
+begin
+  ProgressbarEx.DrawStyle := TProgressbarDrawStyle(rgDrawingStyle.ItemIndex);
+end;
+
+procedure TForm1.rgOrientationClick(Sender: TObject);
+begin
+  ProgressbarEx.Orientation := TProgressbarOrientation(RgOrientation.ItemIndex);
+
+  Progressbar1.Orientation := ProgressBarEx.Orientation;
+  if Progressbar1.Orientation in [pbVertical, pbTopDown] then
+  begin
+    Progressbar1.Left := 32;
+    Progressbar1.Top := 8;
+  end else
+  begin
+    Progressbar1.Left := 8;
+    Progressbar1.Top := 32;
+  end;
+  Progressbar1.Width := ProgressbarEx.Width;
+  Progressbar1.Height := ProgressbarEx.Height;
+end;
+
+procedure TForm1.Edit1Change(Sender: TObject);
+begin
+  ProgressbarEx.Caption := Edit1.Text;
+end;
+
+procedure TForm1.btnFontClick(Sender: TObject);
+begin
+  FontDialog1.Font := ProgressbarEx.Font;
+  if FontDialog1.Execute then
+    ProgressbarEx.Font := FontDialog1.Font;
+end;
+
+procedure TForm1.CheckBox1Change(Sender: TObject);
+begin
+  Progressbar1.Visible := Checkbox1.Checked;
+end;
+
+procedure TForm1.clbBackColorColorChanged(Sender: TObject);
+begin
+  ProgressbarEx.BackColor := clbBackColor.ButtonColor;
+end;
+
+procedure TForm1.clbBarColorColorChanged(Sender: TObject);
+begin
+  ProgressbarEx.BarColor := clbBarColor.ButtonColor;
+end;
+
+procedure TForm1.clbGradientEndColorColorChanged(Sender: TObject);
+begin
+  ProgressbarEx.GradientEndColor := clbGradientEndColor.ButtonColor;
+end;
+
+procedure TForm1.clbBorderColorColorChanged(Sender: TObject);
+begin
+  ProgressbarEx.BorderColor := clbBorderColor.ButtonColor;
+end;
+
+procedure TForm1.ScrollBar1Change(Sender: TObject);
+begin
+  ProgressbarEx.Position := Scrollbar1.Position;
+  ProgressbarEx.Caption := IntToStr(Scrollbar1.Position);
+
+  Progressbar1.Position := Scrollbar1.Position;
+end;
+
+procedure TForm1.seMarqueeLengthChange(Sender: TObject);
+begin
+  ProgressbarEx.MarqueeLength := seMarqueeLength.Value;
+end;
+
+procedure TForm1.seMarqueeSpeedChange(Sender: TObject);
+begin
+  ProgressbarEx.MarqueeSpeed := seMarqueeSpeed.Value;
+end;
+
+end.
+
--- a/components/exctrls/exctrlspkg.lpk
+++ b/components/exctrls/exctrlspkg.lpk
@ -18,7 +18,7 @@
 - TRadioButton, TCheckbox, TRadioGroup and TCheckGroup: drawn by ThemeServices/Canvas, not by widgetset, button/text layout, wordwrap, user-provided check images
 - TColumnComboBoxEx"/>
    <License Value="LGPL with linking exception (like Lazarus LCL)."/>
-    <Files Count="8">
+    <Files Count="9">
      <Item1>
        <Filename Value="source\excheckctrls.pas"/>
        <UnitName Value="ExCheckCtrls"/>
@ -51,6 +51,10 @@
        <Filename Value="source\eximglist.pas"/>
        <UnitName Value="ExImgList"/>
      </Item8>
+      <Item9>
+        <Filename Value="source\exprogressbar.pas"/>
+        <UnitName Value="ExProgressbar"/>
+      </Item9>
    </Files>
    <CompatibilityMode Value="True"/>
    <LazDoc Paths="fpdoc"/>
--- a/components/exctrls/exctrlspkg.pas
+++ b/components/exctrls/exctrlspkg.pas
@ -9,7 +9,7 @@ interface

 uses
  ExCheckCtrls, ExEditCtrls, ExButtons, ExCombo, ExCheckCombo, ExQuestionDlg, 
-  ExShape, ExImgList;
+  ExShape, ExImgList, ExProgressbar;

 implementation

--- a/components/exctrls/images/imagelist.txt
+++ b/components/exctrls/images/imagelist.txt
@ -28,3 +28,6 @@ tcheckcomboboxex_200.png
 tshapeex.png
 tshapeex_150.png
 tshapeex_200.png
+tprogressbarex.png
+tprogressbarex_150.png
+tprogressbarex_200.png
--- a/components/exctrls/images/tprogressbarex.png
+++ b/components/exctrls/images/tprogressbarex.png
--- a/components/exctrls/images/tprogressbarex_150.png
+++ b/components/exctrls/images/tprogressbarex_150.png
--- a/components/exctrls/images/tprogressbarex_200.png
+++ b/components/exctrls/images/tprogressbarex_200.png
--- a/components/exctrls/source/design/exctrlsreg.pas
+++ b/components/exctrls/source/design/exctrlsreg.pas
@ -22,7 +22,7 @@ implementation
 {$R exctrlsreg.res}

 uses
-  ExButtons, ExCheckCtrls, ExEditCtrls, ExCombo, ExCheckCombo, ExShape;
+  ExButtons, ExCheckCtrls, ExEditCtrls, ExCombo, ExCheckCombo, ExShape, ExProgressBar;

 function TFloatSIPropertyEditor.GetValue: ansistring;
 begin
@ -54,6 +54,7 @@ begin
    TButtonEx, TCheckboxEx, TRadioButtonEx, TCheckGroupEx, TRadioGroupEx,
    TFloatSISpinEditEx, TCurrSpinEditEx,
    TColumnComboBoxEx, TCheckComboBoxEx,
+    TProgressBarEx,
    TShapeEx
  ]);

--- a/components/exctrls/source/design/exctrlsreg.res
+++ b/components/exctrls/source/design/exctrlsreg.res
--- a/components/exctrls/source/exprogressbar.pas
+++ b/components/exctrls/source/exprogressbar.pas
@ -0,0 +1,416 @@
+unit ExProgressbar;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, Graphics, Types, Controls, ExtCtrls, ComCtrls;
+
+type
+  TProgressbarDrawStyle = (pdsFlat, pdsGradient, pdsRounded, pdsShiny, pdsBevel);
+
+  TProgressbarEx = class(TGraphicControl)
+  private
+    const
+      DEFAULT_BACKCOLOR = $E6E6E6;
+      DEFAULT_BARCOLOR = $06B025;
+      DEFAULT_GRADIENTENDCOLOR = $00FFFF;
+      DEFAULT_BORDERCOLOR = clSilver;
+      DEFAULT_MARQUEELENGTH = 120;
+      DEFAULT_MARQUEESPEED = 8;
+  private
+    FCaption: String;
+    FColors: array[0..3] of TColor;
+    FDrawStyle: TProgressbarDrawStyle;
+    FMarqueePosition: Integer;
+    FMarqueeLength: Integer;
+    FMarqueeSpeed: Integer;
+    FMax: Integer;
+    FMin: Integer;
+    FOrientation: TProgressBarOrientation;  // (pbHorizontal, pbVertical, pbRightToLeft, pbTopDown)
+    FPosition: Integer;
+    FStyle: TProgressBarStyle;              // (pbstNormal, pbstMarquee)
+    FTimer: TTimer;
+    function GetColors(AIndex: Integer): TColor;
+    procedure SetCaption(AValue: String);
+    procedure SetColors(AIndex: Integer; AValue: TColor);
+    procedure SetDrawStyle(AValue: TProgressbarDrawStyle);
+    procedure SetMax(AValue: Integer);
+    procedure SetMin(AValue: Integer);
+    procedure SetOrientation(AValue: TProgressbarOrientation);
+    procedure SetPosition(AValue: Integer);
+    procedure SetStyle(AValue: TProgressbarStyle);
+    procedure TimerHandler(Sender: TObject);
+  protected
+    procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
+      const AXProportion, AYProportion: Double); override;
+    function GetBarRect: TRect;
+    class function GetControlClassDefaultSize: TSize; override;
+    function IsHorizontal(AOrientation: TProgressbarOrientation): Boolean;
+    procedure Paint; 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 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;
+    property DrawStyle: TProgressbarDrawStyle read FDrawStyle write SetDrawStyle default pdsFlat;
+    property MarqueeLength: Integer read FMarqueeLength write FMarqueeLength default DEFAULT_MARQUEELENGTH;
+    property MarqueeSpeed: Integer read FMarqueeSpeed write FMarqueeSpeed default DEFAULT_MARQUEESPEED;
+    property Max: Integer read FMax write SetMax default 100;
+    property Min: Integer read FMin write SetMin default 0;
+    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 Align;
+    property Anchors;
+    property BorderSpacing;
+    property Constraints;
+    property Font;
+    property Hint;
+    property ParentFont;
+    property ParentShowHint;
+    property ShowHint;
+    property Visible;
+  end;
+
+implementation
+
+uses
+  GraphUtil;
+
+constructor TProgressbarEx.Create(AOwner: TComponent);
+begin
+  inherited;
+  FCaption := '';
+  FColors[0] := DEFAULT_BACKCOLOR;
+  FColors[1] := DEFAULT_BORDERCOLOR;
+  FColors[2] := DEFAULT_BARCOLOR;
+  FColors[3] := DEFAULT_GRADIENTENDCOLOR;
+  FMarqueeLength := DEFAULT_MARQUEELENGTH;
+  FMarqueeSpeed := DEFAULT_MARQUEESPEED;
+  FMax := 100;
+  FStyle := pbstNormal;
+  FTimer := TTimer.Create(self);
+  FTimer.Interval := 25;
+  FTimer.OnTimer := @TimerHandler;
+  with GetControlClassDefaultSize do
+    SetInitialBounds(0, 0, CX, CY);
+end;
+
+procedure TProgressbarEx.DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
+  const AXProportion, AYProportion: Double);
+begin
+  inherited;
+  if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
+    FMarqueeLength := round(DEFAULT_MARQUEELENGTH * AXProportion);
+end;
+
+function TProgressBarEx.GetBarRect: TRect;
+var
+  fraction: Double;
+begin
+  Result := Rect(1, 1, Width-1, Height-1);
+  fraction := (FPosition - FMin) / (FMax - FMin);
+  case FStyle of
+    pbstNormal:
+      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));
+        end;
+      end;
+    pbstMarquee:
+      case FOrientation of
+        pbHorizontal:
+          begin
+            Result.Right := FMarqueePosition;
+            Result.Left := Result.Right - FMarqueeLength;
+          end;
+        pbRightToLeft:
+          begin
+            Result.Left := Result.Right - FMarqueePosition;
+            Result.Right := Result.Left + FMarqueelength;
+          end;
+        pbVertical:
+          begin
+            Result.Top := Result.Bottom - FMarqueePosition;
+            Result.Bottom := Result.Top + FMarqueeLength;
+          end;
+        pbTopDown:
+          begin
+            Result.Bottom := FMarqueePosition;
+            Result.Top := Result.Bottom - FMarqueeLength;
+          end;
+      end;
+  end;
+  if IsHorizontal(FOrientation) then
+  begin
+    if Result.Right >= Width - 1 then Result.Right := Width - 1;
+    if Result.Left < 1 then Result.Left := 1;
+  end else
+  begin
+    if Result.Bottom >= Height - 1 then Result.Bottom := Height - 1;
+    if Result.Top < 1 then Result.Top := 1;
+  end;
+end;
+
+function TProgressbarEx.GetColors(AIndex: Integer): TColor;
+begin
+  Result := FColors[AIndex];
+end;
+
+class function TProgressbarEx.GetControlClassDefaultSize: TSize;
+begin
+  Result.CX := 200;
+  Result.CY := 20;
+end;
+
+function TProgressbarEx.IsHorizontal(AOrientation: TProgressbarOrientation): Boolean;
+begin
+  Result := (AOrientation in [pbHorizontal, pbRightToLeft]);
+end;
+
+procedure TProgressbarEx.Paint;
+var
+  R, R1, R2: TRect;
+  FontAngle: Integer;
+  txtSize: TSize;
+  isHor: Boolean;
+  col1, col2, col3: TColor;
+begin
+  isHor := IsHorizontal(FOrientation);
+
+  // Draw background with border
+  Canvas.Brush.Style := bsSolid;
+  Canvas.Brush.Color := BackColor;
+  Canvas.Pen.Color := BorderColor;
+  Canvas.Rectangle(0, 0, Width, Height);
+
+  // Draw bar
+  R := GetBarRect;
+  if isHor then
+    FontAngle := 0
+  else
+    FontAngle := 900;
+  case FDrawStyle of
+    pdsFlat:
+      begin
+        Canvas.Brush.Color := BarColor;
+        Canvas.FillRect(R);
+      end;
+    pdsGradient:
+      begin
+        case FOrientation of
+          pbHorizontal:
+            Canvas.GradientFill(R, BarColor, GradientEndColor, gdHorizontal);
+          pbVertical:
+            Canvas.GradientFill(R, GradientEndColor, barColor, gdVertical);
+          pbRightToLeft:
+            Canvas.GradientFill(R, GradientEndColor, BarColor, gdHorizontal);
+          pbTopDown:
+            Canvas.GradientFill(R, BarColor, GradientEndColor, gdVertical);
+        end;
+      end;
+    pdsRounded:
+      begin
+        col2 := BarColor;
+        col1 := GetHighlightColor(col2, 60);
+        col3 := GetShadowColor(col2, -60);
+        R1 := R;
+        R2 := R;
+        if isHor then
+        begin
+          R1.Bottom := R.Top + R.Height div 2;
+          R2.Top := R1.Bottom;
+          Canvas.GradientFill(R1, col1, col2, gdVertical);
+          Canvas.GradientFill(R2, col2, col3, gdVertical);
+        end else
+        begin
+          R1.Right := R.Left + R.Width div 2;
+          R2.Left := R1.Right;
+          Canvas.GradientFill(R1, col1, col2, gdHorizontal);
+          Canvas.GradientFill(R2, col2, col3, gdHorizontal);
+        end;
+      end;
+    pdsShiny:
+      begin
+        col1 := GetHighlightColor(BarColor, 50);
+        col2 := GetHighlightColor(BarColor, 25);
+        col3 := GetShadowColor(BarColor, -20);
+        R1 := R;
+        R2 := R;
+        if isHor then
+        begin
+          R1.Bottom := R.Top + R.Height div 3;
+          R2.Top := R1.Bottom ;
+          Canvas.GradientFill(R1, col1, col2, gdVertical);
+          Canvas.GradientFill(R2, BarColor, col3, gdVertical);
+        end else
+        begin
+          R1 := R;
+          R1.Right := R.Left + R.Width div 3;
+          R2.Left := R1.Right;
+          Canvas.GradientFill(R1, col1, col2, gdHorizontal);
+          Canvas.GradientFill(R2, BarColor, col3, gdHorizontal);
+        end;
+      end;
+    pdsBevel:
+      begin
+        col1 := BarColor;
+        Canvas.Brush.Color := col1;
+        inc(R.Right);
+        Canvas.FillRect(R);
+        col2 := GetShadowColor(col1, -30);
+        col1 := GetHighlightColor(col1, 30);
+        R1 := R;
+        InflateRect(R1, -1, -1);
+        R2 := R;
+        InflateRect(R2, -2, -2);
+        Canvas.Pen.Color := col1;
+        Canvas.Line(R1.Right, R1.Top, R1.Left, R1.Top);
+        Canvas.Line(R2.Right, R2.Top, R2.Left, R2.Top);
+        Canvas.Line(R1.Left, R.Top, R1.Left, R1.Bottom);
+        Canvas.Line(R2.Left, R2.Top, R2.Left, R2.Bottom);
+        Canvas.Pen.Color := col2;
+        Canvas.Line(R1.Left, R1.Bottom, R1.Right, R1.Bottom);
+        Canvas.Line(R2.Left, R2.Bottom, R2.Right, R2.Bottom);
+        Canvas.Line(R1.Right, R1.Bottom, R1.Right, R1.Top);
+        Canvas.Line(R2.Right, R2.Bottom, R2.Right, R2.Top);
+      end;
+    else
+      raise Exception.Create('DrawStyle not implemented.');
+  end;
+
+  // Draw text
+  if FCaption <> '' then
+  begin
+    txtSize := Canvas.TextExtent(FCaption);
+    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)
+    else
+      Canvas.TextOut((Width - txtSize.CY) div 2, R.Bottom - (Height - txtSize.CX) div 2, FCaption);
+  end;
+end;
+
+procedure TProgressbarEx.SetCaption(AValue: String);
+begin
+  if FCaption = AValue then
+    exit;
+  FCaption := AValue;
+  Invalidate;
+end;
+
+procedure TProgressbarEx.SetColors(AIndex: Integer; AValue: TColor);
+begin
+  if FColors[AIndex] = AValue then
+    exit;
+  FColors[AIndex] := AValue;
+  Invalidate;
+end;
+
+procedure TProgressbarEx.SetDrawStyle(AValue: TProgressbarDrawStyle);
+begin
+  if FDrawStyle = AValue then
+    exit;
+  FDrawStyle := AValue;
+  Invalidate;
+end;
+
+procedure TProgressbarEx.SetMax(AValue: Integer);
+begin
+  if FMax = AValue then
+    exit;
+  FMax := AValue;
+  Invalidate;
+end;
+
+procedure TProgressbarEx.SetMin(AValue: Integer);
+begin
+  if FMin = AValue then
+    exit;
+  FMin := AValue;
+  Invalidate;
+end;
+
+procedure TProgressbarEx.SetOrientation(AValue: TProgressbarOrientation);
+var
+  rotate: Boolean;
+begin
+  if FOrientation = AValue then
+    exit;
+  rotate := IsHorizontal(AValue) xor IsHorizontal(FOrientation);
+  FOrientation := AValue;
+  if rotate then
+    SetBounds(Left, Top, Height, Width)
+  else
+    Invalidate;
+end;
+
+procedure TProgressbarEx.SetPosition(AValue: Integer);
+begin
+  if FPosition = AValue then
+    exit;
+  if AValue > FMax then
+    FPosition := FMax
+  else if AValue < FMin then
+    FPosition := FMin
+  else
+    FPosition := AValue;
+  Invalidate;
+end;
+
+procedure TProgressbarEx.SetStyle(AValue: TProgressbarStyle);
+begin
+  if FStyle = AValue then
+    exit;
+  FStyle := AValue;
+  case FStyle of
+    pbstNormal:
+      begin
+        FPosition := FMin;
+        FTimer.Enabled := false;
+      end;
+    pbstMarquee:
+      begin
+        FMarqueePosition := 0;
+        FTimer.Enabled := true;
+      end;
+  end;
+end;
+
+procedure TProgressbarEx.TimerHandler(Sender: TObject);
+begin
+  inc(FMarqueePosition, FMarqueeSpeed);
+  if IsHorizontal(FOrientation) then
+  begin
+    if (FMarqueePosition - FMarqueeLength > Width) and (FMarqueeSpeed > 0) then
+      FMarqueePosition := 0
+    else
+    if (FMarqueePosition < 0) and (FMarqueeSpeed < 0) then
+      FMarqueePosition := Width + FMarqueeLength;
+  end else
+  begin
+    if (FMarqueePosition - FMarqueeLength > Height) and (FMarqueeSpeed > 0) then
+      FMarqueePosition := 0
+    else
+    if (FMarqueePosition < 0) and (FMarqueeSpeed < 0) then
+      FMarqueePosition := Height + FMarqueeLength;
+  end;
+  Invalidate;
+end;
+
+end.
+