lazarus-ccr/components/exctrls/source/exprogressbar.pas

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;

    property OnPaint;
  end;

implementation

uses
  GraphUtil;

constructor TProgressbarEx.Create(AOwner: TComponent);
begin
  inherited;
  ControlStyle := ControlStyle - [csSetCaption];

  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;
  FTimer.Enabled := false;

  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;

  inherited;
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.