Chip 1998 March/Chip_1998-03_cd.bin/zkuste/delphi/WhiteAnts/PROGRESS.ZIP/PROGRESS.PAS

Pascal/Delphi Source File | 1997-01-10 | 13.1 KB | 479 lines

{
+----------------------------------------------------------------------------+
|                                      ⌐  ⌐                                  |
|                                    ⌐⌐ ⌐ ⌐ ⌐                                |
|                                 ⌐⌐⌐ ⌐   ⌐  ⌐                               |
|                                 ⌐⌐    ⌐ ⌐   ⌐                              |
|                  ⌐             ⌐⌐     ⌐  ⌐                                 |
|                 ⌐ ⌐            ⌐⌐⌐    ⌐⌐  ⌐                                |
|             ⌐⌐  ⌐  ⌐      ⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐  ⌐                                    |
|            ⌐  ⌐⌐  ⌐⌐      ⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐                                  |
|            ⌐ ⌐⌐⌐ ⌐⌐⌐⌐⌐⌐ ⌐⌐⌐ ⌐   ⌐⌐⌐⌐⌐⌐⌐⌐                                   |
|           ⌐ ⌐⌐ ⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐ ⌐   ⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐      Copyright ⌐ 1996-1997 by:  |
|           ⌐ ⌐⌐⌐⌐⌐⌐ ⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐  ⌐ ⌐⌐⌐⌐⌐ ⌐⌐                                 |
|          ⌐ ⌐⌐⌐⌐⌐⌐⌐   ⌐⌐⌐⌐⌐ ⌐⌐⌐⌐    ⌐⌐ ⌐⌐ ⌐      WHITE ANTS SYSTEMHOUSE BV  |
|         ⌐  ⌐⌐⌐⌐⌐⌐⌐ ⌐⌐⌐ ⌐⌐⌐ ⌐⌐ ⌐       ⌐⌐⌐⌐      Geleen 12                  |
|         ⌐ ⌐⌐⌐⌐⌐⌐⌐    ⌐   ⌐⌐   ⌐⌐⌐       ⌐       8032 GB Zwolle             |
|           ⌐⌐⌐⌐⌐⌐     ⌐            ⌐ ⌐           Netherlands                |
|      ⌐⌐⌐  ⌐⌐⌐⌐⌐      ⌐     ⌐⌐     ⌐  ⌐                                     |
|            ⌐⌐       ⌐              ⌐  ⌐⌐⌐ ⌐     Tel. [phone]      |
|      ⌐              ⌐              ⌐            Fax. [phone]      |
|      ⌐             ⌐               ⌐⌐                                      |
|    ⌐              ⌐                  ⌐⌐         www.whiteants.com          |
|  ⌐⌐              ⌐                     ⌐ ⌐      [e-mail]      |
|                 ⌐                                                          |
+----------------------------------------------------------------------------+
  file     : Progress
  version  : 1.0
  comment  :
  date     : 09-01-97
  time     : 12:30:32
  author   : G. Beuze
  compiler : Delphi 1.0
+----------------------------------------------------------------------------+
| DISCLAIMER:                                                                |
| THIS SOURCE IS FREEWARE. YOU ARE ALLOWED TO USE IT IN YOUR OWN PROJECTS    |
| WITHOUT ANY RESTRICTIONS. YOU ARE NOT ALLOWED TO SELL THE SOURCE CODE.     |
| THERE IS NO WARRANTY AT ALL - YOU USE IT ON YOUR OWN RISC. WHITE ANTS DOES |
| NOT ASSUME ANY RESPONSIBILITY FOR ANY DAMAGE OR ANY LOSS OF TIME OR MONEY  |
| DUE THE USE OF ANY PART OF THIS SOURCE CODE.                               |
+----------------------------------------------------------------------------+
}

unit Progress;

interface

uses Classes, SysUtils, IntLists, Controls;

type
  TProgressObserver = class;

  TProgressor = class (TObject)
  private
    FAborted: Boolean;
    FBusyCursor: TCursor;
    FCursorStack: TIntList;
    FDescription: PString;
    FDescrStack: TStrings;
    FObservers: TList;
    FOrgCursor: TCursor;
    FProgress: Integer;
    FProgressBusy: Boolean;
    FProgressStack: TIntList;
  protected
    constructor CreateInstance;
    procedure DescriptionChange;
    function GetAborted: Boolean;
    function GetDescription: String;
    procedure PopProgress;
    procedure ProgressChange;
    procedure ProgressEnd;
    procedure ProgressStart;
    procedure PushProgress;
    procedure SetBusyCursor(Value: TCursor);
    procedure SetDescription(const Value: String);
    procedure SetProgress(Value: Integer);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Abort;
    procedure EndProgress;
    class function Instance: TProgressor;
    procedure RegisterObserver(Observer: TProgressObserver);
    procedure StartProgress(AProgress: Integer; const ADescription: String);
    procedure StartProgressDef;
    procedure UnregisterObserver(Observer: TProgressObserver);
    property Aborted: Boolean read GetAborted write FAborted;
    property BusyCursor: TCursor read FBusyCursor write SetBusyCursor;
    property Description: String read GetDescription write SetDescription;
    property Progress: Integer read FProgress write SetProgress;
  end;

  TProgressObserver = class (TComponent)
  private
    FAccuracy: Integer;
    FEnabled: Boolean;
    FLastProgress: Integer;
    FOnDescriptionChange: TNotifyEvent;
    FOnFinish: TNotifyEvent;
    FOnProgressChange: TNotifyEvent;
    FOnStart: TNotifyEvent;
  protected
    procedure DescriptionChange;
    function GetAborted: Boolean;
    function GetBusyCursor: TCursor;
    function GetDescription: String;
    function GetProgress: Integer;
    function GetProgressor: TProgressor;
    procedure ProgressChange;
    procedure ProgressEnd;
    procedure ProgressStart;
    procedure SetAborted(Value: Boolean);
    procedure SetAccuracy(Value: Integer);
    procedure SetBusyCursor(Value: TCursor);
    procedure SetDescription(Value: String);
    procedure SetProgress(Value: Integer);
    property Progressor: TProgressor read GetProgressor;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Abort;
    procedure EndProgress;
    procedure StartProgress(AProgress: Integer; const ADescription: String);
    procedure StartProgressDef;
    property Aborted: Boolean read GetAborted write SetAborted;
    property Description: String read GetDescription write SetDescription;
    property Progress: Integer read GetProgress write SetProgress default 0;
  published
    property Accuracy: Integer read FAccuracy write SetAccuracy default 5;
    property BusyCursor: TCursor read GetBusyCursor write SetBusyCursor default
        crHourGlass;
    property Enabled: Boolean read FEnabled write FEnabled default True;
    property OnDescriptionChange: TNotifyEvent read FOnDescriptionChange write
        FOnDescriptionChange;
    property OnFinish: TNotifyEvent read FOnFinish write FOnFinish;
    property OnProgressChange: TNotifyEvent read FOnProgressChange write
        FOnProgressChange;
    property OnStart: TNotifyEvent read FOnStart write FOnStart;
  end;


procedure Register;

implementation

uses StrUtils, NumUtils, Forms;

procedure Register;
begin
  RegisterComponents('White Ants', [TProgressObserver]);
end;

{ FProgressor stores TProgressor singleton instance }
const
  FProgressor: TProgressor = nil;

{
********************************* TProgressor **********************************
}
constructor TProgressor.Create;
begin
  inherited Create;
  raise Exception.Create('Access TProgressor through Instance');
end;

constructor TProgressor.CreateInstance;
begin
  inherited Create;
  FCursorStack := TIntList.Create;
  FDescrStack := TStringList.Create;
  FObservers := TList.Create;
  FProgressStack := TIntList.Create;
  FBusyCursor := crHourGlass;
  FProgressor := Self;
  FOrgCursor := crDefault;
end;

destructor TProgressor.Destroy;
begin
  FCursorStack.Free;
  DisposeStr(FDescription);
  FDescrStack.Free;
  FObservers.Free;
  FProgressStack.Free;
  if FProgressor = Self then FProgressor := nil;
  inherited Destroy;
end;

procedure TProgressor.Abort;
begin
  Aborted := True;
end;

procedure TProgressor.DescriptionChange;
var
  I: Integer;
  Obs: TProgressObserver;
begin
  for I := 0 to FObservers.Count - 1 do
  begin
    Obs := FObservers[I];
    if Obs.Enabled then Obs.DescriptionChange;
  end;
end;

procedure TProgressor.EndProgress;
begin
  FProgressBusy := FProgressStack.Count > 0;
  if FProgressBusy then PopProgress;
  if not FProgressBusy then ProgressEnd;
end;

function TProgressor.GetAborted: Boolean;
begin
  Result := FAborted or Application.Terminated;
end;

function TProgressor.GetDescription: String;
begin
  Result := StringValue(FDescription);
end;

class function TProgressor.Instance: TProgressor;
begin
  Result := FProgressor;
  if not Assigned(Result) then
    Result := TProgressor.CreateInstance;
end;

procedure TProgressor.PopProgress;
var
  Cnt,AProgress: Integer;
begin
  Cnt := FProgressStack.Count;
  if Cnt > 0 then
  begin
    Progress := FProgressStack.Items[Pred(Cnt)];
    FProgressStack.Delete(Pred(Cnt));
  end;
  Cnt := FDescrStack.Count;
  if Cnt > 0 then
  begin
    Description := FDescrStack[Pred(Cnt)];
    FDescrStack.Delete(Pred(Cnt));
  end;
  Cnt := FCursorStack.Count;
  if Cnt > 0 then
  begin
    Screen.Cursor := TCursor(FCursorStack[Pred(Cnt)]);
    FCursorStack.Delete(Pred(Cnt));
  end;
end;

procedure TProgressor.ProgressChange;
var
  I: Integer;
  Obs: TProgressObserver;
begin
  for I := 0 to FObservers.Count - 1 do
  begin
    Obs := FObservers[I];
    if Obs.Enabled then Obs.ProgressChange;
  end;
end;

procedure TProgressor.ProgressEnd;
var
  I: Integer;
  Obs: TProgressObserver;
begin
  Screen.Cursor := FOrgCursor;
  for I := 0 to FObservers.Count - 1 do
  begin
    Obs := FObservers[I];
    if Obs.Enabled then Obs.ProgressEnd;
  end;
end;

procedure TProgressor.ProgressStart;
var
  I: Integer;
  Obs: TProgressObserver;
begin
  FAborted := False;
  FOrgCursor := Screen.Cursor;
  Screen.Cursor := FBusyCursor;
  for I := 0 to FObservers.Count - 1 do
  begin
    Obs := FObservers[I];
    if Obs.Enabled then Obs.ProgressStart;
  end;
end;

procedure TProgressor.PushProgress;
begin
  FProgressStack.Add(Progress);
  FDescrStack.Add(Description);
  FCursorStack.Add(Ord(Screen.Cursor));
end;

procedure TProgressor.RegisterObserver(Observer: TProgressObserver);
begin
  if FObservers.IndexOf(Observer) = -1 then
    FObservers.Add(Observer);
end;

procedure TProgressor.SetBusyCursor(Value: TCursor);
begin
  FBusyCursor := Value;
  if FProgressBusy then Screen.Cursor := FBusyCursor;
end;

procedure TProgressor.SetDescription(const Value: String);
begin
  if Value <> Description then
  begin
    AssignStr(FDescription, Value);
    DescriptionChange;
  end;
end;

procedure TProgressor.SetProgress(Value: Integer);
begin
  if Value <> FProgress then
  begin
    FProgress := Value;
    ProgressChange;
  end;
end;

procedure TProgressor.StartProgress(AProgress: Integer; const ADescription:
    String);
var
  WasBusy: Boolean;
begin
  WasBusy := FProgressBusy;
  FProgressBusy := True;
  if WasBusy then PushProgress;
  Progress := AProgress;
  Description := ADescription;
  if not WasBusy then ProgressStart;
end;

procedure TProgressor.StartProgressDef;
begin
  StartProgress(0, '');
end;

procedure TProgressor.UnregisterObserver(Observer: TProgressObserver);
begin
  FObservers.Remove(Observer);
end;

{
****************************** TProgressObserver *******************************
}
constructor TProgressObserver.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FEnabled := True;
  FAccuracy := 5;
  Progressor.RegisterObserver(Self);
end;

destructor TProgressObserver.Destroy;
begin
  Progressor.UnregisterObserver(Self);
  inherited Destroy;
end;

procedure TProgressObserver.Abort;
begin
  Progressor.Abort;
end;

procedure TProgressObserver.DescriptionChange;
begin
  if Assigned(FOnDescriptionChange) then FOnDescriptionChange(Self);
end;

procedure TProgressObserver.EndProgress;
begin
  Progressor.EndProgress;
end;

function TProgressObserver.GetAborted: Boolean;
begin
  Result := Progressor.Aborted;
end;

function TProgressObserver.GetBusyCursor: TCursor;
begin
  Result := Progressor.BusyCursor;
end;

function TProgressObserver.GetDescription: String;
begin
  Result := Progressor.Description;
end;

function TProgressObserver.GetProgress: Integer;
begin
  Result := Progressor.Progress;
end;

function TProgressObserver.GetProgressor: TProgressor;
begin
  Result := TProgressor.Instance;
end;

procedure TProgressObserver.ProgressChange;
var
  NewProgress: Integer;
begin
  NewProgress := Progress;
  if (FLastProgress div FAccuracy) <> (NewProgress div FAccuracy) then
  begin
    FLastProgress := NewProgress;
    if Assigned(FOnProgressChange) then FOnProgressChange(Self);
  end;
end;

procedure TProgressObserver.ProgressEnd;
begin
  if Assigned(FOnFinish) then FOnFinish(Self);
end;

procedure TProgressObserver.ProgressStart;
begin
  if Assigned(FOnStart) then FOnStart(Self);
end;

procedure TProgressObserver.SetAborted(Value: Boolean);
begin
  Progressor.Aborted := Value;
end;

procedure TProgressObserver.SetAccuracy(Value: Integer);
begin
  FAccuracy := LimitToRange(Value, 1, 50);
end;

procedure TProgressObserver.SetBusyCursor(Value: TCursor);
begin
  Progressor.BusyCursor := Value;
end;

procedure TProgressObserver.SetDescription(Value: String);
begin
  Progressor.Description := Value;
end;

procedure TProgressObserver.SetProgress(Value: Integer);
begin
  Progressor.Progress := Value;
end;

procedure TProgressObserver.StartProgress(AProgress: Integer; const
    ADescription: String);
begin
  Progressor.StartProgress(AProgress, ADescription);
end;

procedure TProgressObserver.StartProgressDef;
begin
  Progressor.StartProgressDef;
end;


procedure ShutDown; far;
begin
  FProgressor.Free;
end;

initialization
  AddExitProc(ShutDown);
end.