UNE BARRE DE COMPRESSION ET PROGRESSION DE TYPE WINRAR (TRARBAR)

unit rar_bar;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics,
  Controls, Forms, Dialogs, StdCtrls, Consts;

type
  TRarBar = class(TCustomControl)
  private
    FMinValue: Integer;
    FMaxValue: Integer;
    FCurValue: Integer;
    FRatValue: Integer;
    FBackColor: TColor;
    FOnProgress: TNotifyEvent;
    procedure PaintBackground;
    procedure PaintProgress;
    procedure PaintRate;
    procedure SetBackColor(Value: TColor);
    procedure SetMinValue(Value: Longint);
    procedure SetMaxValue(Value: Longint);
    procedure SetProgress(Value: Longint);
    procedure SetRate(Value: Longint);
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure IncrementProgress;
    procedure IncrementRate;
     function GetPercentDone: integer;
     function GetRatePercentDone: integer;
  published
    property Align;
    property Enabled;
    property ShowHint;
    property Hint;
    property Visible;
    property ParentShowHint;
    property PopupMenu;
    property BackColor: TColor read FBackColor write SetBackColor default clBtnFace;
    property Min: Longint read FMinValue write SetMinValue default 0;
    property Max: Longint read FMaxValue write SetMaxValue default 100;
    property Position: Longint read FCurValue write SetProgress;
    property Rate: Longint read FRatValue write SetRate;
  {évènements}
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;
end;

var RarBmp : TBitmap;

procedure Register;

implementation

  function SolveForY(X, Z: Integer): integer;
  begin
    if Z=0 then Result := 0
    else Result:=trunc((X*100)/Z);
  end;

constructor TRarBar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque, csCaptureMouse,
                                  csClickEvents, csDoubleClicks];
  FMinValue:=0;
  FMaxValue:=100;
  FCurValue:=0;
  FRatValue:=0;
  FBackColor:=clBtnFace;
  Width:=177;
  Height:=17;
end;

function TRarBar.GetPercentDone: integer;
begin
  Result := SolveForY(FCurValue - FMinValue, FMaxValue - FMinValue);
end;

function TRarBar.GetRatePercentDone: integer;
begin
  Result := SolveForY(FRatValue - FMinValue, FMaxValue - FMinValue);
end;

procedure TRarBar.Paint;
begin
  with Canvas do
    begin
      rarbmp.Height:=Height;
      rarbmp.Width:=Width;
      PaintBackground;
      PaintProgress;
      PaintRate;
      Canvas.Draw(0,0,RarBmp);
      if Assigned(FOnProgress) then FOnProgress(Self);
      Refresh;
    end;
end;

procedure TRarBar.PaintBackground;
begin
  with RarBmp.Canvas do
    begin
  {--- arrière plan ---}
      Brush.Style:=bsSolid;
      Brush.Color:=FBackColor;
      Pen.Color:=FBackColor;
      RarBmp.Canvas.Rectangle(0,0,Width,Height);
  {--- fond noir ---}
      Brush.Style:=bsSolid;
      Brush.Color:=clBlack;
      Pen.Width:=1;
      Pen.Color:=clBlack;
      RarBmp.Canvas.Rectangle(1,2,Width,Height);
  {--- contour beige ---}
      Brush.Style:=bsClear;
      Pen.Width:=1;
      Pen.Color:=$9898B8;
      RarBmp.Canvas.Rectangle(0,0,Width-1,Height-2);
  {--- contour beige ---}
      Brush.Style:=bsClear;
      Pen.Width:=1;
      Pen.Color:=$9898B8;
      RarBmp.Canvas.Rectangle(0,0,Width-1,Height-2);
  {--- contour pourpre ---}
      Brush.Style:=bsClear;
      Pen.Width:=1;
      Pen.Color:=$8080A0;
      RarBmp.Canvas.Rectangle(1,1,Width-2,Height-3);
  {--- remplissage ---}
      Brush.Style:=bsSolid;
      Brush.Color:=$707098;
      Pen.Color:=$707098;
      Pen.Width:=1;
      RarBmp.Canvas.Rectangle(2,2,Width-3,Height-4);
  {--- ligne grise ---}
      Pen.Color:=$606060;
      Pen.Width:=1;
      RarBmp.Canvas.MoveTo(0,Height-2);
      RarBmp.Canvas.LineTo(Width-1,Height-2);
    end;
end;

procedure TRarBar.PaintProgress;
var i, wi : integer;
begin
  with RarBmp.Canvas do
    begin
      i:=GetPercentDone;
{--- trace bordure gauche ---}
        if i>0 then
          begin
    {--- ligne blanche ---}
            Pen.Color:=clWhite;
            Pen.Width:=1;
            RarBmp.Canvas.MoveTo(0,0);
            RarBmp.Canvas.LineTo(0,Height-2);
    {--- ligne violasse ---}
            Pen.Color:=$F0E8E8;
            Pen.Width:=1;
            RarBmp.Canvas.MoveTo(1,0);
            RarBmp.Canvas.LineTo(1,Height-2);
          end;

{--- trace le remplissage ---}
        wi:=((Width-3)*i) div 100+2;
          {--- ligne blanche ---}
            Pen.Color:=clWhite;
            Pen.Width:=1;
            RarBmp.Canvas.MoveTo(2,0);
            RarBmp.Canvas.LineTo(wi,0);
          {--- ligne violasse ---}
            Pen.Color:=$F0E8E8;
            Pen.Width:=1;
            //haut
            RarBmp.Canvas.MoveTo(2,1);
            RarBmp.Canvas.LineTo(wi,1);
            //bas
            RarBmp.Canvas.MoveTo(2,Height-3);
            RarBmp.Canvas.LineTo(wi,Height-3);
          {--- remplissage ---}
            Brush.Style:=bsSolid;
            Brush.Color:=$D8D8D8;
            Pen.Color:=$D8D8D8;
            Pen.Width:=1;
            RarBmp.Canvas.Rectangle(2,2,wi,Height-3);

{--- trace du marqueur relief ---}
            if wi>2 then
              begin
                Pixels[1,0]:=clWhite;
                Pixels[wi-1,0]:=clWhite;
                Pen.Width:=1;
                Pen.Color:=$F0E8E8;
                MoveTo(wi-1,1);
                LineTo(wi-1,Height-3);
              end;
            if wi<Width-2 then
              begin
                Pixels[wi+1,0]:=$9898B8;
                Pixels[wi+1,Height-3]:=$9898B8;
              end;
            if (wi>2) and (wi<Width-2) then
              begin
                Pen.Color:=$8080A0;
                MoveTo(wi+1,1);
                LineTo(wi+1,Height-4);

                Pen.Color:=$606060;
                MoveTo(wi,0);
                LineTo(wi,Height-2);
              end;
    end;
end;

procedure TRarBar.PaintRate;
var i, wi : integer;
begin
  with RarBmp.Canvas do
    begin
      i:=GetRatePercentDone;
{--- trace bordure gauche ---}
        if i>0 then
          begin
    {--- ligne jaune ---}
            Pen.Color:=$C0FFFF;
            Pen.Width:=1;
            RarBmp.Canvas.MoveTo(0,0);
            RarBmp.Canvas.LineTo(0,Height-2);
    {--- ligne orangée ---}
            Pen.Color:=$B8D8E8;
            Pen.Width:=1;
            RarBmp.Canvas.MoveTo(1,0);
            RarBmp.Canvas.LineTo(1,Height-2);
          end;

{--- trace le remplissage ---}
        wi:=((Width-3)*i) div 100+2;
          if wi>2 then
            Pixels[1,0]:=$C0FFFF;
          {--- ligne jaune ---}
            Pen.Color:=$C0FFFF;
            Pen.Width:=1;
            RarBmp.Canvas.MoveTo(2,0);
            RarBmp.Canvas.LineTo(wi,0);
          {--- ligne orangée ---}
            Pen.Color:=$B8D8E8;
            Pen.Width:=1;
            //haut
            RarBmp.Canvas.MoveTo(2,1);
            RarBmp.Canvas.LineTo(wi,1);
            //bas
            RarBmp.Canvas.MoveTo(2,Height-3);
            RarBmp.Canvas.LineTo(wi,Height-3);
          {--- remplissage ---}
            Brush.Style:=bsSolid;
            Brush.Color:=$A0C0D0;
            Pen.Color:=$A0C0D0;
            Pen.Width:=1;
            RarBmp.Canvas.Rectangle(2,2,wi,Height-3);
    end;
end;

procedure TRarBar.SetMinValue(Value: Longint);
begin
  if Value <> FMinValue then
  begin
    if Value > FMaxValue then
      if not (csLoading in ComponentState) then
        raise EInvalidOperation.CreateFmt(SOutOfRange, [-MaxInt, FMaxValue - 1]);
    FMinValue := Value;
    if FCurValue < Value then FCurValue := Value;
    if FRatValue < Value then FRatValue := Value;
    Refresh;
  end;
end;

procedure TRarBar.SetMaxValue(Value: Longint);
begin
  if Value <> FMaxValue then
  begin
    if Value < FMinValue then
      if not (csLoading in ComponentState) then
        raise EInvalidOperation.CreateFmt(SOutOfRange, [FMinValue + 1, MaxInt]);
    FMaxValue := Value;
    if FCurValue > Value then FCurValue := Value;
    if FRatValue > Value then FRatValue := Value;
    Refresh;
  end;
end;

procedure TRarBar.SetProgress(Value: Longint);
var TempPercent: integer;
begin
  TempPercent := GetPercentDone;  { remember where we were }
  if Value < FMinValue then
    Value := FMinValue
  else if Value > FMaxValue then
    Value := FMaxValue;
  if FCurValue <> Value then
    begin
      FCurValue := Value;
      if TempPercent <> GetPercentDone then { only Refresh if percentage changed }
        Refresh;
    end;
end;

procedure TRarBar.SetRate(Value: Longint);
var TempPercent: integer;
begin
  TempPercent := GetRatePercentDone;  { remember where we were }
  if Value < FMinValue then
    Value := FMinValue
  else if Value > FMaxValue then
    Value := FMaxValue;
  if FRatValue <> Value then
    begin
      FRatValue := Value;
      if TempPercent <> GetRatePercentDone then { only Refresh if percentage changed }
        Refresh;
    end;
end;

procedure TRarBar.SetBackColor(Value: TColor);
begin
  if Value <> FBackColor then
    begin
      FBackColor:=Value;
      Refresh;
    end;
end;

procedure TRarBar.IncrementProgress;
begin
  Position:=FCurValue+1;
end;

procedure TRarBar.IncrementRate;
begin
  Position:=FRatValue+1;
end;

procedure Register;
begin
  RegisterComponents('Win32', [TRarBar]);
end;

initialization
  rarbmp:=TBitmap.Create;
finalization
  rarbmp.Free;
end.