{

  Copyright (C) 2007 Laurent Jacques

  This source is free software; you can redistribute it and/or modify it under
  the terms of the GNU General Public License as published by the Free
  Software Foundation; either version 2 of the License, or (at your option)
  any later version.

  This code is distributed in the hope that it will be useful, but WITHOUT ANY
  WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  details.

  A copy of the GNU General Public License is available on the World Wide Web
  at <http://www.gnu.org/copyleft/gpl.html>. You can also obtain it by writing
  to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  MA 02111-1307, USA.
}

unit ColorProgress;

{$MODE objfpc}{$H+}

interface

uses
  LResources, Classes, SysUtils, Controls, Graphics, FPCanvas;

type

  TColorProgressKind = (ckText, ckHorizontalBar, ckHorRoundBar, ckVerticalBar,
    ckVerRoundBar, ckPie, ckBitmap);

  { TColorProgress }

  TColorProgress = class(TGraphicControl)
  private
    { Private declarations }
    FBackColor: TColor;
    FBorderStyle: TBorderStyle;
    FCurValue: longint;
    FForeColor: TColor;
    FForeStyle: TFPBrushStyle;
    FForeImage: TBitmap;
    FKind:     TColorProgressKind;
    FMaxValue: longint;
    FMinValue: longint;
    FShowText: boolean;
    FGetForeImage: boolean;
    procedure DrawRoundBar;
    procedure DrawBar;
    procedure DrawText;
    procedure DrawPie;
    procedure DrawBitmap;
    function GetPercentDone: longint;
    procedure SetBackColor(AValue: TColor);
    procedure SetForeColor(AValue: TColor);
    procedure SetForeStyle(AValue: TFPBrushStyle);
    procedure SetForeImage(AValue: TBitmap);
    procedure SetGaugeKind(const AValue: TColorProgressKind);
    procedure SetMaxValue(AValue: longint);
    procedure SetMinValue(AValue: longint);
    procedure SetProgress(AValue: longint);
    procedure SetShowText(AValue: boolean);
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(TheOwner: TComponent); override;
    destructor Destroy; override;
    procedure AddProgress(AValue: longint);
    procedure Paint; override;
    property PercentDone: longint Read GetPercentDone;
  published
    { Published declarations }
    property Align;
    property Anchors;
    property BackColor: TColor Read FBackColor Write SetBackColor default clWhite;
    property Color;
    property Constraints;
    property Enabled;
    property ForeColor: TColor Read FForeColor Write SetForeColor default clBlack;
    property ForeStyle: TFPBrushStyle Read FForeStyle Write SetForeStyle default bsSolid;
    property ForeImage: TBitmap Read FForeImage Write SetForeImage;
    property Font;
    property Kind: TColorProgressKind Read FKind Write SetGaugeKind default
      ckHorizontalBar;
    property MinValue: longint Read FMinValue Write SetMinValue default 0;
    property MaxValue: longint Read FMaxValue Write SetMaxValue default 100;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property Progress: longint Read FCurValue Write SetProgress;
    property ShowHint;
    property ShowText: boolean Read FShowText Write SetShowText default True;
    property Visible;
  end;

procedure Register;

implementation

uses Math;

procedure Register;
begin
  RegisterComponents('Wile64', [TColorProgress]);
end;

constructor TColorProgress.Create(TheOwner: TComponent);
begin
  inherited Create(TheOwner);
  ControlStyle := ControlStyle + [csReplicatable];
  FMinValue  := 0;
  FMaxValue  := 100;
  FCurValue  := 0;
  FBorderStyle := bsSingle;
  FForeColor := clBlack;
  FBackColor := clWhite;
  FShowText  := True;
  FKind      := ckHorizontalBar;
  Width      := 100;
  Height     := 20;
  FForeImage := TBitmap.Create;
  FGetForeImage:=false;
end;

destructor TColorProgress.Destroy;
begin
  FForeImage.Free;
  inherited Destroy;
end;

procedure TColorProgress.Paint;
begin
  case Kind of
    ckText: DrawText;
    ckHorizontalBar,
    ckVerticalBar: DrawBar;
    ckHorRoundBar,
    ckVerRoundBar: DrawroundBar;
    ckPie: DrawPie;
    ckBitmap: DrawBitmap;
  end;
  if ShowText and (Kind <> ckText) then
    DrawText;
  inherited Paint;
end;

procedure TColorProgress.SetForeColor(AValue: TColor);
begin
  if AValue <> FForeColor then
  begin
    FForeColor := AValue;
    Refresh;
  end;
end;

procedure TColorProgress.DrawRoundBar;
var
  FillSize: longint;
  MinSize:  longint;
begin
  with Canvas do
  begin
    Brush.Color := BackColor;
    Brush.Style := bsSolid;
    MinSize     := Min(self.Width, self.Height);
    Pen.Color   := cl3DLight;
    RoundRect(1, 1, self.Width, self.Height, MinSize div 4, MinSize div 4);
    Brush.Style := bsClear;
    Pen.Color := cl3DDkShadow;
    RoundRect(0, 0, self.Width - 1, self.Height - 1, MinSize div 4, MinSize div 4);
    Brush.Style := ForeStyle;
    Brush.Color := ForeColor;
    Pen.Color := BackColor;
    if percentdone > 0 then
      case Kind of
        ckHorRoundBar:
        begin
          FillSize := Trunc((self.Width - 2) * (PercentDone / 100));
          RoundRect(Rect(2, 2, FillSize, self.Height - 2), MinSize div
            4, MinSize div 4);
        end;
        ckVerRoundBar:
        begin
          FillSize := Trunc((self.Height - 2) * (PercentDone / 100));
          RoundRect(Rect(2, Self.Height - 2 - FillSize, Self.Width - 2, Self.Height - 3),
            MinSize div 4, MinSize div 4);
        end;
      end;
  end;
end;

procedure TColorProgress.DrawBar;
var
  FillSize: longint;
begin
  with Canvas do
  begin
    Brush.Color := BackColor;
    Pen.Color   := cl3DLight;
    Rectangle(1, 1, self.Width, self.Height);
    Brush.Style := bsClear;
    Pen.Color := cl3DDkShadow;
    Rectangle(0, 0, self.Width-1, self.Height-1);
    Brush.Style := ForeStyle;
    Brush.Color := ForeColor;
    if percentdone > 0 then
      case Kind of
        ckHorizontalBar:
        begin
          FillSize := Trunc((self.Width - 4) * (PercentDone / 100));
          FillRect(Rect(2, 2, FillSize + 2, self.Height - 2));
        end;
        ckVerticalBar:
        begin
          FillSize := Trunc((self.Height - 4) * (PercentDone / 100));
          FillRect(Rect(2, Self.Height - 2 - FillSize, Self.Width - 2, Self.Height - 2));
        end;
      end;
  end;
end;

procedure TColorProgress.DrawText;
var
  X, Y: integer;
  S:    string;
begin
  with Canvas do
  begin
    if Kind = ckText then
    begin
      Brush.Color := BackColor;
      Brush.Style := bsSolid;
      Pen.Color   := clGray;
      Rectangle(0, 0, self.Width, self.Height);
      Pen.Color := clSilver;
      Rectangle(1, 1, self.Width - 1, self.Height - 1);
    end;
    Font := Self.Font;
    S    := format('%d%%', [PercentDone]);
    Y    := (self.Height div 2) - (TextHeight(S) div 2);
    X    := (self.Width div 2) - (TextWidth(S) div 2);
    TextRect(self.ClientRect, X, Y-1, S);
  end;
end;

procedure TColorProgress.DrawPie;
var
  MiddleX, MiddleY: integer;
  Angle: double;
begin
  with Canvas do
  begin
    Brush.Color := BackColor;
    Brush.Style := bsSolid;
    Pen.Color   := cl3DLight;
    Ellipse(1, 1, self.Width, self.Height);
    Pen.Color := cl3DDkShadow;
    Ellipse(0, 0, self.Width - 1, self.Height - 1);
    Brush.Style := ForeStyle;
    Brush.Color := ForeColor;
    if PercentDone > 0 then
    begin
      MiddleX := (self.Width - 2) div 2;
      MiddleY := (self.Height - 2) div 2;
      Angle   := (Pi * ((PercentDone / 50) + 0.5));
      Pie(2, 2, self.Width - 3, self.Height - 3,
        integer(Round(MiddleX * (1 - Cos(Angle)))),
        integer(Round(MiddleY * (1 - Sin(Angle)))), MiddleX + 1, 1);
    end;
  end;
end;

procedure TColorProgress.DrawBitmap;
var
  FillSize: longint;
  MinSize:  longint;
  SrcRect, DstRect: TRect;
  bmp:      TBitmap;
begin
  with Canvas do
  begin
    if not FGetForeImage then
    begin
      bmp         := TBitmap.Create;
      Bmp.Width   := self.Width;
      Bmp.Height  := Self.Height;
      Bmp.Canvas.StretchDraw(rect(0, 0, self.Width, self.Height), FForeImage);
      FForeImage.Assign(Bmp);
      bmp.Free;
      FGetForeImage:=true;
    end;
    MinSize     := Min(self.Width + 2, self.Height + 2);
    FillSize    := Trunc((self.Width - 4) * (PercentDone / 100));
    DstRect     := Rect(2, 2, FillSize + 2, self.Height -2);
    Brush.Color := BackColor;
    Brush.Style := bsSolid;
    Pen.Color   := cl3DLight;
    CopyMode    := cmSrcCopy;
    RoundRect(1, 1, self.Width, self.Height, MinSize div 4, MinSize div 4);
    CopyRect(DstRect, FForeImage.Canvas, DstRect);
    Brush.Style := bsclear;
    RoundRect(1, 1, self.Width, self.Height, MinSize div 4, MinSize div 4);
    Pen.Color   := cl3DDkShadow;
    RoundRect(0, 0, self.Width - 1, self.Height - 1, MinSize div 4, MinSize div 4);
  end;
end;

function TColorProgress.GetPercentDone: longint;
begin
  Result := trunc(100.0 * (FCurValue / FMaxValue));
end;

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

procedure TColorProgress.SetMinValue(AValue: longint);
begin
  if AValue <> FMinValue then
  begin
    FMinValue := AValue;
    Refresh;
  end;
end;

procedure TColorProgress.SetMaxValue(AValue: longint);
begin
  if AValue <> FMaxValue then
  begin
    FMaxValue := AValue;
    Refresh;
  end;
end;

procedure TColorProgress.SetShowText(AValue: boolean);
begin
  if AValue <> FShowText then
  begin
    FShowText := AValue;
    Refresh;
  end;
end;

procedure TColorProgress.SetForeStyle(AValue: TFPBrushStyle);
begin
  if AValue <> FForeStyle then
  begin
    FForeStyle := AValue;
    Refresh;
  end;
end;

procedure TColorProgress.SetForeImage(AValue: TBitmap);
var
  NewBitmap: TBitmap;
begin
  if AValue <> FForeImage then
  begin
    NewBitmap := TBitmap.Create;
    NewBitmap.Assign(AValue);
    FForeImage.Height := self.Height;
    FForeImage.Width  := self.Width;
    FForeImage.Canvas.StretchDraw(Rect(0, 0, Width, Height-1), NewBitmap);
    NewBitmap.Free;
    Refresh;
  end;
end;

procedure TColorProgress.SetGaugeKind(const AValue: TColorProgressKind);
begin
  if AValue <> FKind then
  begin
    FKind := AValue;
    Refresh;
  end;
end;


procedure TColorProgress.SetProgress(AValue: longint);
begin
  if AValue < FMinValue then
    AValue := FMinValue
  else if AValue > FMaxValue then
    AValue := FMaxValue;
  if FCurValue <> AValue then
  begin
    FCurValue := AValue;
    Refresh;
  end;
end;

procedure TColorProgress.AddProgress(AValue: longint);
begin
  Progress := FCurValue + AValue;
  Refresh;
end;

initialization
{$I colorprogress.lrs}

end.