BARRE DE PROGRESSION À LA CLEARLOOKS

unit GrProgressBar;

(* ***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (the "License"); you may not use this file except in compliance with
 * the License. You may obtain a copy of the License at
 * http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS IS" basis,
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 * for the specific language governing rights and limitations under the
 * License.
 *
 * The Original Code is GrProgressBar
 *
 * The Initial Developer of the Original Code is
 * Yann Papouin <yann.papouin at @ gmail.com>
 *
 * ***** END LICENSE BLOCK ***** *)
 
{ $DEFINE DEBUG}

interface

uses
  {$IfDef DEBUG}DbugIntf,{$ENDIF}
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Math,
  GR32, GR32_Image, GR32_Polygons, SimpleTimer;

type
  TBarDirection = (
    bdRight,
    bdLeft
  );

  TGrProgressbar = class(TCustomImage32)
  private
    FModulo : integer;
    FInvalidateColor : boolean;
    FApplyingSystemColor: boolean;
    FColor1 : TColor32;
    FColor2 : TColor32;
    FBarDirection : TBarDirection;
    FLimitRight : integer;
    FLimitLeft : integer;
    FBar : TPolygon32;
    FAniTimer: TSimpleTimer;
    FInvalidatePattern : boolean;
    FFiller: TBitmapPolygonFiller;
    FUseSystemColors: boolean;
    FAnimated: boolean;
    FMax: integer;
    FMin: integer;
    FPosition: integer;
    FMarquee: boolean;
    FMarqueeWidth: single;
    FMarqueeSpeed: integer;
    FColor: TColor;
    FAnimAtMax: boolean;
    FFlip: boolean;
    procedure SetUseSystemColors(const Value: boolean);
    procedure SetAnimated(const Value: boolean);
    { Déclarations privées }
    procedure ComputePattern;
    procedure InvalidatePattern;
    procedure SetMax(const Value: integer);
    procedure SetMin(const Value: integer);
    procedure SetPosition(Value: integer);
    procedure DoAniTimer(Sender: TObject);
    procedure SetInterval(const Value: Cardinal);
    function GetInterval: Cardinal;
    procedure SetMarquee(const Value: boolean);
    procedure SetMarqueeWidth(Value: single);
    procedure SetMarqueeSpeed(const Value: integer);
    procedure SetColor(const Value: TColor);
    procedure SetAnimAtMax(const Value: boolean);
    procedure SetFlip(const Value: boolean);
  protected
    procedure BuildBar;
    procedure Resize; override;
    procedure DoPaintBuffer; override;
    function InternalPaintBuffer(aBitmap32: TBitmap32): Boolean;
    procedure DrawBackground(aBitmap32: TBitmap32);
    procedure CMStyleChanged( var msg: TMessage); message WM_THEMECHANGED;
    procedure CMShowingChanged(var msg: TMessage); message CM_SHOWINGCHANGED;
  public
    { Déclarations publiques }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;
  published
    property Align;
    property AlignWithMargins;
    property Anchors;
    property Margins;
    property AnimAtMax : boolean read FAnimAtMax write SetAnimAtMax;
    property Animated : boolean read FAnimated write SetAnimated;
    property Interval : Cardinal read GetInterval write SetInterval;
    property UseSystemColors : boolean read FUseSystemColors write SetUseSystemColors;
    property Max : integer read FMax write SetMax;
    property Min : integer read FMin write SetMin;
    property Position : integer read FPosition write SetPosition;
    property Marquee : boolean read FMarquee write SetMarquee;
    property MarqueeWidth : single read FMarqueeWidth write SetMarqueeWidth;
    property MarqueeSpeed : integer read FMarqueeSpeed write SetMarqueeSpeed;
    property Color : TColor read FColor write SetColor;
    property Flip : boolean read FFlip write SetFlip;
  end;


procedure Register;

implementation

uses
  Themes, UxTheme;

var
  SystemColor : TColor;

procedure Register;
begin
  RegisterComponents('GLDali', [TGrProgressbar]);
end;


function Linearize(Ax, Ay, Bx, By, Value : Single): Single;
begin
  if (Bx <> Ax) and (Ay <> By) then
    result := Ay + (Value - Ax) / (Bx - Ax) * (By-Ay)
  else
    result := 0;
end;


{ TGrProgressbar }

constructor TGrProgressbar.Create(AOwner: TComponent);
begin
  inherited;
  
  Height := 15;
  Width := 150;

  FFlip := true;
  FModulo := Height;
  FMin := 0;
  FMax := 100;
  FMarqueeWidth := 0.25;
  FMarqueeSpeed := 5;
  FBar := TPolygon32.Create;

  FAniTimer := TSimpleTimer.CreateEx(50, DoAniTimer);
  FFiller := TBitmapPolygonFiller.Create;

  ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
    csSetCaption, csParentBackground, csDoubleClicks, csReplicatable, csPannable];

  //Color := clHighlight;
  Animated := true;
end;

destructor TGrProgressbar.Destroy;
begin
  FAniTimer.Free;
  FFiller.Free;
  FBar.Free;
  inherited;
end;

procedure TGrProgressbar.Loaded;
begin
  inherited Loaded;
  Buffer.SetSize(Width,Height);
  BuildBar;
  InvalidatePattern;
  {$IfDef DEBUG}SendDebugFmt('Progress bar named %s loaded',[Name]);{$ENDIF}
end;


procedure TGrProgressbar.InvalidatePattern;
begin
  FInvalidatePattern := true;
  Changed;
end;


// The pattern is computed only once
// It need to be recomputed after a resize of the control or a color (theme) change
procedure TGrProgressbar.ComputePattern;
var
  Polygon : TPolygon32;
  PatternWidth : integer;
  PatternHeight : integer;
begin
  PatternHeight := Height;
  PatternWidth := PatternHeight*2;
  FModulo := PatternWidth;

  if Assigned(FFiller.Pattern) then
    FFiller.Pattern.Free;

  // First create a rectangle with the wanted color
  FFiller.Pattern := TBitmap32.Create;
  FFiller.Pattern.SetSize(PatternWidth,PatternHeight);
  FFiller.Pattern.FillRectTS(0,0,PatternWidth,PatternHeight, FColor1);

  PatternHeight := PatternHeight;

  Polygon := TPolygon32.Create;

  // Next draw a transparent parallelogram (a rectangle that is skewed)
  with Polygon do
  begin
    Antialiased := true;
    Add(FixedPoint(0,0));
    Add(FixedPoint(PatternWidth div 2,0));
    Add(FixedPoint(PatternWidth, PatternHeight));
    Add(FixedPoint(PatternWidth div 2, PatternHeight));
    DrawFill(FFiller.Pattern, SetAlpha(FColor2,127));

    // Mirror operation on vertical axis if needed
    if Flip then
      FFiller.Pattern.FlipHorz(FFiller.Pattern);
  end;
  Polygon.Free;

  // Finally draw a crystal effect
  FFiller.Pattern.FillRectTS(0, 0, PatternWidth, PatternHeight div 2, SetAlpha(CLWhite32,60));
end;


procedure TGrProgressbar.BuildBar;
var
  LPosition : integer;
  Offset : integer;
  Inflate : integer;
  DrawRect : TRect;
begin

  if not Assigned(Parent) then
    Exit;

  // Inflate value help to reduce the bar size from it's background
  Inflate := -3;

  // An offset is here to correct the 3D effect
  Offset := -1;

  // Get X coordinate from the Min, Max and Position Values
  if not Marquee then
  begin
    LPosition := Round(Linearize(Min, -2* Inflate + Offset, Max, Width, Position));
    {$IfDef DEBUG}SendInteger('LPosition',LPosition);{$ENDIF}
  end;

  DrawRect := ClientRect;

  // Limits are used by the marquee animation
  FLimitRight := DrawRect.Right + Inflate;
  FLimitLeft := DrawRect.Left - Inflate + Offset;

  if not Marquee then
    DrawRect.Right := LPosition
  else
    DrawRect.Right := Round(DrawRect.Right*MarqueeWidth);  // setting the marquee width by using it's percent value

  // Apply the offset
  DrawRect.Top := DrawRect.Top + Offset;
  DrawRect.Left := DrawRect.Left + Offset;

  InflateRect(DrawRect, Inflate, Inflate);

  {$IfDef DEBUG}SendInteger('DrawRect.Left',DrawRect.Left);{$ENDIF}
  {$IfDef DEBUG}SendInteger('DrawRect.Right',DrawRect.Right);{$ENDIF}
  
  // Drawing the bar polygon
  with FBar do
  begin
    Clear;
    if DrawRect.Left <> DrawRect.Right then
    begin
      Add(FixedPoint(DrawRect.Left,DrawRect.Top));
      Add(FixedPoint(DrawRect.Right,DrawRect.Top));
      Add(FixedPoint(DrawRect.Right,DrawRect.Bottom));
      Add(FixedPoint(DrawRect.Left,DrawRect.Bottom));
    end;
  end;
end;

procedure TGrProgressbar.DrawBackground(aBitmap32: TBitmap32);
var
  R: TRect;
  cl: TColor;
  FProgressThemeData : HTHEME;
begin

  if UseThemes then
  begin
    // Apply the WinXP style
    FProgressThemeData := OpenThemeData(Handle, 'Progress');
    R := ClientRect;
    DrawThemeBackground(FProgressThemeData, aBitmap32.Handle, PP_BAR, 0, R, nil);
  end
    else
  begin
    // Mimic the Win2K style by drawing a lowered borders
    aBitmap32.RaiseRectTS(0,0,width,height,-50);
  end;

end;


function TGrProgressbar.InternalPaintBuffer(aBitmap32: TBitmap32): Boolean;
var
  Polygon : TPolygon32;
  LPosition : integer;
  Inflate : integer;
  DrawRect : TRect;
begin

  // Do not try to draw anything is there is no parent for self
  if not Assigned(Parent) then
  begin
    aBitmap32.Clear(clRed32);
    Exit;
  end;

  // Recalc color after a theme change
  if FInvalidateColor then
  begin
    UseSystemColors := UseSystemColors;
    FInvalidateColor := false;
  end;

  // Recalc pattern on resize or color change
  if FInvalidatePattern then
  begin
    FInvalidatePattern := false;
    ComputePattern;
  end;

  // Draw the control background (themed if we can)
  DrawBackground(aBitmap32);

  // Draw the bar itself by using the pattern
  if ((Position > 0) and not Marquee) or Marquee then
  begin
    with FBar do
    begin
      // The pattern is automatically repeated on x-axis and y-axis
      DrawFill(aBitmap32, FFiller);
      DrawEdge(aBitmap32, SetAlpha(clBlack32, 100));
    end;
  end;

  result := true;
end;

procedure TGrProgressbar.DoPaintBuffer;
begin
  inherited;
  InternalPaintBuffer(self.Buffer);
end;

// Recompute bar size and pattern size
procedure TGrProgressbar.Resize;
begin
  inherited;
  BuildBar;
  InvalidatePattern;
end;

procedure TGrProgressbar.DoAniTimer(Sender: TObject);
begin
  if not FMarquee then
  begin
    if not ((Position = Max) and not FAnimAtMax) then
    begin
      // Animate pattern of the bar with a scroll
      FFiller.OffsetX := (FFiller.OffsetX-1) mod FModulo;
    end;
  end
    else
  if FMarquee then
  begin
    // Changing direction from right to left
    if (FBar.Points[0][1].X >= Fixed(FLimitRight)) and (FBarDirection = bdRight) then
    begin
      FBarDirection := bdLeft;
    end;

    // Changing direction from left to right
    if (FBar.Points[0][0].X <= Fixed(FLimitLeft)) and (FBarDirection = bdLeft) then
    begin
      FBarDirection := bdRight;
    end;

    // Move the bar itself without moving the pattern
    case FBarDirection of
      bdRight :
        begin
          FBar.Offset(Fixed(FMarqueeSpeed), Fixed(0));
        end;
      bdLeft  :
        begin
          FBar.Offset(Fixed(-FMarqueeSpeed), Fixed(0));
        end;
    end;

  end;

  // Repaint control
  Changed;
end;

// Boolean value to enable/disable animation
procedure TGrProgressbar.SetAnimated(const Value: boolean);
begin
  FAnimated := Value;

  if Visible then
    FAniTimer.Enabled := FAnimated;

  // Reset pattern position
  if not FAnimated then
    FFiller.OffsetX := 0;
end;

// Continue scrolling when Position = Max ?
procedure TGrProgressbar.SetAnimAtMax(const Value: boolean);
begin
  FAnimAtMax := Value;
end;

function TGrProgressbar.GetInterval: Cardinal;
begin
  result := FAniTimer.Interval;
end;

procedure TGrProgressbar.SetInterval(const Value: Cardinal);
begin
  FAniTimer.Interval := Value;
end;

// A marquee progress bar is a progress bar with unknow min, max and position values
// It's a feedback to state to warn the user that a thing is currently doing something
procedure TGrProgressbar.SetMarquee(const Value: boolean);
begin
  if FMarquee <> Value then
  begin
    FMarquee := Value;
    if not FMarquee then
    begin
      Position := Min;
    end;
  end;

  BuildBar;
end;

// The marquee width is it's width in percentage of the bar width
procedure TGrProgressbar.SetMarqueeWidth(Value: single);
begin
  Value := Math.Min(1.0,Value);
  Value := Math.Max(0.0,Value);
  if FMarqueeWidth <> Value then
  begin
    FMarqueeWidth := Value;

    BuildBar;
  end;
end;

procedure TGrProgressbar.SetMarqueeSpeed(const Value: integer);
begin
  if FMarqueeSpeed <> Value then
  begin
    FMarqueeSpeed := Value;
    FMarqueeSpeed := Math.Min(100,FMarqueeSpeed);
    FMarqueeSpeed := Math.Max(1,FMarqueeSpeed);
  end;
end;

procedure TGrProgressbar.SetMax(const Value: integer);
begin
  if FMax <> Value then
  begin
    FMax := Value;
    BuildBar;
  end;
  Position := Position; 
end;

procedure TGrProgressbar.SetMin(const Value: integer);
begin
  if FMin <> Value then
  begin
    FMin := Value;
    BuildBar;
  end;
  Position := Position;
end;


procedure TGrProgressbar.SetPosition(Value: integer);
begin
  // First, limit the setted value to min and max position
  Value := Math.Min(Max, Value);
  Value := Math.Max(Min, Value);

  // Disable marquee if we write a new position
  FMarquee := false;

  if FPosition <> Value then
  begin
    FPosition := Value;
    BuildBar;
    Changed;
  end;
end;

procedure TGrProgressbar.SetUseSystemColors(const Value: boolean);
var
  ABmp : TBitmap;
  PickColor: TColor;
  FProgressThemeData : HTHEME;
begin
  FUseSystemColors := Value;

  if FUseSystemColors then
  begin
    FApplyingSystemColor := true;

    // Check if Windows Themes are enabled
    if UseThemes then
    begin

      // A small way (not really clean) to get the color of a themed progress bar
      if (SystemColor = clNone) then
      begin
        {$IfDef DEBUG}SendDebug('SystemColor is None');{$ENDIF}

        // We create a local bitmap where we painting on it a themed progress bar
        ABmp := TBitmap.Create;
        ABmp.SetSize(16,16);
        FProgressThemeData := OpenThemeData(Handle, 'Progress');
        DrawThemeBackground(FProgressThemeData, ABmp.Canvas.Handle, PP_CHUNK, 0, ABmp.Canvas.ClipRect, nil);
        CloseThemeData(FProgressThemeData);

        // After painting, we pick the color at a logical position
        // Just hope that there is a valid color here
        PickColor := ABmp.Canvas.Pixels[2,2];
        if PickColor <> CLR_INVALID then
        begin
          SystemColor := PickColor;
          {$IfDef DEBUG}SendDebug('System color found, extracted from BITMAP');{$ENDIF}
        end
          else
        begin
          SystemColor := clHighlight;
          {$IfDef DEBUG}SendDebug('System color not found, using the Highlight one');{$ENDIF}
        end;

        ABmp.Free;
      end;

      Color := SystemColor;
      {$IfDef DEBUG}SendDebug('Using previous computed system color');{$ENDIF}
    end
      else
    begin
      // If theming is not enabled then use the default highlight color
      Color := clHighlight;
      {$IfDef DEBUG}SendDebug('No theme is used, default highlight color');{$ENDIF}
    end;
    FApplyingSystemColor := false;
  end;

end;



procedure TGrProgressbar.SetColor(const Value: TColor);
var
  H,S,L : Byte;
begin
  if FColor <> Value then
  begin

    // Disable system color only if SetColor is not called by the UseSystemColors method
    if not FApplyingSystemColor then
      UseSystemColors := false;

    FColor := Value;

    // Extracting the Wincolor to Hue, Saturation and Luminosity values
    FColor1 := Color32(FColor);
    RGBtoHSL(FColor1, H, S, L);

    // Small way to set the color of the slashes
    if Intensity(FColor1) > 160
    then
      FColor2 := clBlack32
    else
      FColor2 := clWhite32;

    // Redraw the pattern with new colors
    InvalidatePattern;
  end;
  
end;

// Property that allow the flippig of the slashes
procedure TGrProgressbar.SetFlip(const Value: boolean);
begin
  FFlip := Value;
  InvalidatePattern;
end;

/// Catched Windows messages

// If the theme is changed by a new theme then invalidate the system color
// It will be recomputed by the first progress bar with UseSystemColor property enabled
procedure TGrProgressbar.CMStyleChanged(var msg: TMessage);
begin
  {$IfDef DEBUG}SendDebug('TGrProgressbar.CMStyleChanged');{$ENDIF}
  // Update colors
  SystemColor := clNone;
  FInvalidateColor := true;
end;


// Stop the timer when this control is not visible, else re-enable it
procedure TGrProgressbar.CMShowingChanged(var msg: TMessage);
begin
  inherited;
  {$IfDef DEBUG}SendDebug('CMShowingChanged');{$ENDIF}
  
  if Showing then
  begin
    if Animated and not FAniTimer.Enabled then
    begin
      FAniTimer.Enabled := true;
      {$IfDef DEBUG}SendDebugFmt('Timer of %s started',[Name]);{$ENDIF}
    end;
  end
    else
  begin
    if Animated and FAniTimer.Enabled then
    begin
      FAniTimer.Enabled := false;
      {$IfDef DEBUG}SendDebugFmt('Timer of %s stopped',[Name]);{$ENDIF}
    end;
  end;
end;

initialization
  SystemColor := clNone;

finalization


end.