Barre de progression à la clearlooks

Télécharger le projet
Commenter

Description

Voici un composant basé sur la librairie Graphics32 qui permet d'être utilisé en tant que barre de progression animée. Une option "marquee" permet de rendre son état indéterminé.

Pour compiler la source, il vous faut les librairies:

Graphics32 : http://graphics32.org/wiki/
The GR32 Extension Components Pack : http://code.google.com/p/gr32ex/

Pour tester l'exemple, renommer le fichier "Exemple.exec" en "Exemple.exe" (merci Nicolas)

Source / Exemple : 


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.
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.