lasarus_compotents/TaskedProgressBar/data/TaskedProgressBar.pas

unit TaskedProgressBar;
{$mode delphi}
{$codepage UTF8}
interface
uses LCLIntf, LCLType, LMessages, windows, Messages, Classes, ComCtrls, shlobj,
     comobj, Controls, sysutils;
type TTaskProgressState = (tpsNoProgress, tpsIndeterminate, tpsNormal, tpsError, tpsPaused);
type
  TTaskProgressBar = class(TComponent)
   private
    fTaskBarList : ITaskBarList3;
    fProgressBar: TProgressBar;
    fAlign: TAlign;
    fBorderSpacing: TControlBorderSpacing;
    fState: TTaskProgressState;
    fWidth, fHeight, fLeft, fTop, fProgress, fProgressMax, fStepDef: Integer;
    fBarShowText, fSmooth: Boolean;
    fHandle: HWND;
    procedure SetAlign (ANewAlign: TAlign);
    procedure SetBarShowText (ANewValue: boolean);
    procedure SetBorderSpacing (ANewSpacing: TControlBorderSpacing);
    procedure SetHeight (ANewHeight: Integer);
    procedure SetLeft (ANewLeft: Integer);
    procedure SetProgress (ANewValue: Integer);
    procedure SetProgressMax (ANewValue: Integer);
    procedure SetSmooth (ANewSmooth: Boolean);
    procedure SetState (ANewState: TTaskProgressState);
    procedure SetStep (ANewStep: Integer);
    procedure SetTop (ANewTop: Integer);
    procedure SetWidth (ANewWidth: Integer);
   public
    constructor Create (AOwner: TComponent);
    destructor Destroy;
    procedure StepBy (const ADelta: Integer);
    procedure StepIt;
    property Align: TAlign read fAlign write SetAlign;
    property BarShowText: Boolean read fBarShowText write SetBarShowText;
    property BorderSpacing: TControlBorderSpacing read fBorderSpacing write SetBorderSpacing;
    property Handle: HWND read fHandle write fHandle;
    property Height: Integer read fHeight write SetHeight;
    property Left: Integer read fLeft write SetLeft;
    property Progress: Integer read fProgress write SetProgress;
    property ProgressMax: Integer read fProgressMax write SetProgressMax;
    property Smooth: Boolean read fSmooth write SetSmooth;
    property State: TTaskProgressState read fState write SetState;
    property Step: Integer read fStepDef write SetStep;
    property Top: Integer read fTop write SetTop;
    property Width: Integer read fWidth write SetWidth;
    end;
procedure Register;
const IID_ITaskbarList3: TGUID = '{ea1afb91-9e28-4b86-90e9-9e9f8a5eefaf}';
implementation
constructor TTaskProgressBar.Create (AOwner: TComponent);
var tbList: ITaskbarList;
    hr: HRESULT;
begin
inherited Create (AOwner);
tbList:= CreateComObject(CLSID_TaskBarList) as ITaskBarList;
hr:= tbList.QueryInterface(IID_ITaskBarList3, fTaskBarList);
if hr <> S_OK then
 begin
 fTaskBarList:= nil;
 tbList._Release;
 raise Exception.Create('Error creation IID_ITaskBarList3 interface!');
 end;
fHandle:= 0;
fState:= tpsNoProgress;
fProgressMax:= 100;
fProgress:= 0;
fWidth:= 100;
fHeight:= 20;
fLeft:= 10;
fTop:= 10;
fAlign:= alNone;
with fBorderSpacing do
 begin
 Around:= 0;
 Bottom:= 0;
 CellAlignHorizontal:= ccaFill;
 CellAlignVertical:= ccaFill;
 InnerBorder:= 0;
 Left:= 0;
 Right:= 0;
 Top:= 0;
 end;
fProgressBar:= TProgressBar.Create(AOwner);
with fProgressBar do
 begin
 Align:= fAlign;
 Max:= fProgressMax;
 Min:= 0;
 Style:= pbstNormal;
 Position:= 0;
 Width:= fWidth;
 Height:= fHeight;
 Left:= fLeft;
 Top:= fTop;
 BorderSpacing:= fBorderSpacing;
 BarShowText:= fBarShowText;
 Smooth:= fSmooth;
 Step:= fStepDef;
 end;
end;
destructor TTaskProgressBar.Destroy;
begin
fTaskBarList:= nil;
fProgressBar.Free;
inherited Destroy;
end;
{Align}
procedure TTaskProgressBar.SetAlign (ANewAlign: TAlign);
begin
fAlign:= ANewAlign;
fProgressBar.Align:= fAlign;
end;
{BarShowText}
procedure TTaskProgressBar.SetBarShowText (ANewValue: boolean);
begin
fBarShowText:= ANewValue;
fProgressBar.BarShowText:= fBarShowText;
end;
{BorderSpacing}
procedure TTaskProgressBar.SetBorderSpacing (ANewSpacing: TControlBorderSpacing);
begin
fBorderSpacing:= ANewSpacing;
fProgressBar.BorderSpacing:= fBorderSpacing;
end;
{Height}
procedure TTaskProgressBar.SetHeight (ANewHeight: Integer);
begin
fHeight:= ANewHeight;
fProgressBar.Height:= fHeight;
end;
{Left}
procedure TTaskProgressBar.SetLeft (ANewLeft: Integer);
begin
fLeft:= ANewLeft;
fProgressBar.Left:= fLeft;
end;
{Progress}
procedure TTaskProgressBar.SetProgress(ANewValue: Integer);
begin
fProgress:= ANewValue;
if Assigned(fTaskBarList) then
 fTaskBarList.SetProgressValue(fHandle, fProgress, fProgressMax);
fProgressBar.Position:= fProgress;
end;
{ProgressMax}
procedure TTaskProgressBar.SetProgressMax(ANewValue: Integer);
begin
fProgressMax:= ANewValue;
fProgressBar.Max:= fProgressMax;
end;
{Smooth}
procedure TTaskProgressBar.SetSmooth (ANewSmooth: Boolean);
begin
fSmooth:= ANewSmooth;
fProgressBar.Smooth:= fSmooth;
end;
{State}
procedure TTaskProgressBar.SetState(ANewState: TTaskProgressState);
 function TTPStoTBPF (AValue: TTaskProgressState): TBPFLAG;
 begin
 Result:= TBPF_NOPROGRESS;
 case AValue of
  tpsNoProgress: Result:= TBPF_NOPROGRESS;
  tpsIndeterminate: Result:= TBPF_INDETERMINATE;
  tpsNormal: Result:= TBPF_NORMAL;
  tpsError: Result:= TBPF_ERROR;
  tpsPaused: Result:= TBPF_PAUSED;
  end;
 end;
begin
fState:= ANewState;
if Assigned(fTaskBarList) then
 fTaskBarList.SetProgressState(fHandle, TTPStoTBPF(ANewState));
if ANewState = tpsIndeterminate then
 fProgressBar.Style:= pbstMarquee
 else
 fProgressBar.Style:= pbstNormal;
end;
{Step}
procedure TTaskProgressBar.SetStep (ANewStep: Integer);
begin
fStepDef:= ANewStep;
fProgressBar.Step:= fStepDef;
end;
{Top}
procedure TTaskProgressBar.SetTop (ANewTop: Integer);
begin
fTop:= ANewTop;
fProgressBar.Top:= fTop;
end;
{Width}
procedure TTaskProgressBar.SetWidth (ANewWidth: Integer);
begin
fWidth:= ANewWidth;
fProgressBar.Width:= fWidth;
end;
{proc: StepBy}
procedure TTaskProgressBar.StepBy (const ADelta: Integer);
begin
fProgress:= fProgress + ADelta;
Progress:= fProgress;
end;
{proc: StepIt}
procedure TTaskProgressBar.StepIt;
begin
StepBy(fStepDef);
end;
procedure Register;
begin
RegisterComponents('ANB Soft Team', [TTaskProgressBar]);
end;
end.