dbprgrss.pas

RX Library contains a large number of components, objects and routines for Borland Delphi with full

{*******************************************************}
{                                                       }
{         Delphi VCL Extensions (RX)                    }
{                                                       }
{         Copyright (c) 1995, 1996 AO ROSNO             }
{         Copyright (c) 1997 Master-Bank                }
{                                                       }
{*******************************************************}

unit DbPrgrss;

interface

{$I RX.INC}
{$T-}

uses Classes, {$IFDEF WIN32} Bde, {$ELSE} DbiTypes, DbiProcs, {$ENDIF WIN32}
  Controls, DB, DBTables, RxTimer;

type
  TOnMessageChange = procedure(Sender: TObject; const Msg: string) of object;
  TOnPercentChange = procedure(Sender: TObject; PercentDone: Integer) of object;
  TOnProgressEvent = procedure(Sender: TObject; var AbortQuery: Boolean) of object;
{$IFDEF WIN32}
  TOnTraceEvent = procedure(Sender: TObject; Flag: TTraceFlag;
    const Msg: string) of object;
{$ENDIF WIN32}

{ TDBProgress }

  TDBProgress = class(TComponent)
  private
    FActive: Boolean;
    FStartTime: Longint;
    FTimer: TRxTimer;
    FWaitCursor: TCursor;
    FGauge: TControl;
    FMessageControl: TControl;
    FStreamedValue: Boolean;
    FGenProgressCallback: TObject;
    FQryProgressCallback: TObject;
    FOnMessageChange: TOnMessageChange;
    FOnPercentChange: TOnPercentChange;
    FOnProgress: TOnProgressEvent;
{$IFDEF WIN32}
    FTraceFlags: TTraceFlags;
    FTraceCallback: TObject;
    FTrace: Boolean;
    FOnTrace: TOnTraceEvent;
    FSessionName: string;
    FSessionLink: TObject;
    procedure SetTrace(Value: Boolean);
    procedure SetTraceFlags(Value: TTraceFlags);
    function TraceCallBack(CBInfo: Pointer): CBRType;
    function GetDBSession: TSession;
    procedure SetSessionName(const Value: string);
    procedure Activate;
    procedure Deactivate;
{$ENDIF WIN32}
    procedure FreeTimer;
    procedure StartTimer;
    procedure TimerExpired(Sender: TObject);
    function GenProgressCallback(CBInfo: Pointer): CBRType;
    function QryProgressCallback(CBInfo: Pointer): CBRType;
    procedure SetActive(Value: Boolean);
    procedure SetPercent(Value: Integer);
    procedure SetMessage(const Value: string);
    procedure SetMessageControl(Value: TControl);
    procedure SetGauge(Value: TControl);
  protected
    procedure Notification(AComponent: TComponent; AOperation: TOperation); override;
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function ProgressMsgValue(const Msg: string): Longint;
  published
    property Active: Boolean read FActive write SetActive default True;
    property WaitCursor: TCursor read FWaitCursor write FWaitCursor default crHourGlass;
    property MessageControl: TControl read FMessageControl write SetMessageControl;
    property Gauge: TControl read FGauge write SetGauge;
{$IFDEF WIN32}
    property SessionName: string read FSessionName write SetSessionName;
    property Trace: Boolean read FTrace write SetTrace default False;
    property TraceFlags: TTraceFlags read FTraceFlags write SetTraceFlags default [];
    property OnTrace: TOnTraceEvent read FOnTrace write FOnTrace;
{$ENDIF WIN32}
    property OnMessageChange: TOnMessageChange read FOnMessageChange write FOnMessageChange;
    property OnPercentChange: TOnPercentChange read FOnPercentChange write FOnPercentChange;
    property OnProgress: TOnProgressEvent read FOnProgress write FOnProgress;
  end;

{ TDBCallback - for internal use only }

type
  TDBCallbackEvent = function(CBInfo: Pointer): CBRType of object;
  TDBCallbackChain = (dcOnlyOnce, dcChain, dcReplace);

  TDBCallback = class(TObject)
  private
    FOwner: TObject;
    FCBType: CBType;
    FCBBuf: Pointer;
    FCBBufLen: Cardinal;
    FOldCBData: Longint;
    FOldCBBuf: Pointer;
    FOldCBBufLen: Word;
    FOldCBFunc: Pointer;
    FInstalled: Boolean;
    FChain: TDBCallbackChain;
    FCallbackEvent: TDBCallbackEvent;
  protected
    function Invoke(CallType: CBType; var CBInfo: Pointer): CBRType;
  public
    constructor Create(AOwner: TObject; CBType: CBType;
      CBBufSize: Cardinal; CallbackEvent: TDBCallbackEvent;
      Chain: TDBCallbackChain);
    destructor Destroy; override;
  end;

implementation

uses {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs, Str16, {$ENDIF WIN32}
  Forms, SysUtils, StdCtrls, Dialogs, MaxMin, RxPrgrss, BdeUtils;

const
  cbQRYPROGRESS = cbRESERVED4;

{ TDBCallback }

function BdeCallBack(CallType: CBType; Data: Longint;
  {$IFNDEF WIN32} var {$ENDIF} CBInfo: Pointer): CBRType;
  {$IFDEF WIN32} stdcall; {$ELSE} export; {$ENDIF WIN32}
begin
  if Data <> 0 then begin
    Result := TDBCallback(Data).Invoke(CallType, CBInfo);
  end
  else Result := cbrUSEDEF;
end;

constructor TDBCallback.Create(AOwner: TObject; CBType: CBType;
  CBBufSize: Cardinal; CallbackEvent: TDBCallbackEvent;
  Chain: TDBCallbackChain);
begin
  FOwner := AOwner;
  FCBType := CBType;
  FCallbackEvent := CallbackEvent;
{$IFDEF WIN32}
  DbiGetCallBack(nil, FCBType, @FOldCBData, @FOldCBBufLen, @FOldCBBuf,
    pfDBICallBack(FOldCBFunc));
{$ELSE}
  DbiGetCallBack(nil, FCBType, FOldCBData, FOldCBBufLen, FOldCBBuf,
    @FOldCBFunc);
{$ENDIF}
  FChain := Chain;
  if not Assigned(FOldCBFunc) then FOldCBBufLen := 0;
  if not Assigned(FOldCBFunc) or (FChain in [dcChain, dcReplace]) then begin
    FCBBufLen := Max(CBBufSize, FOldCBBufLen);
    FCBBuf := AllocMem(FCBBufLen);
    Check(DbiRegisterCallback(nil, FCBType, Longint(Self), FCBBufLen,
      FCBBuf, BdeCallBack));
    FInstalled := True;
  end;
end;

destructor TDBCallback.Destroy;
begin
  if FInstalled then begin
    if Assigned(FOldCBFunc) and (FChain = dcChain) then
    try
      DbiRegisterCallback(nil, FCBType, FOldCBData, FOldCBBufLen,
        FOldCBBuf, pfDBICallback(FOldCBFunc));
    except
    end
    else DbiRegisterCallback(nil, FCBType, 0, 0, nil, nil);
  end;
  if FCBBuf <> nil then FreeMem(FCBBuf, FCBBufLen);
end;

function TDBCallback.Invoke(CallType: CBType; var CBInfo: Pointer): CBRType;
begin
  Result := cbrUSEDEF;
  if CallType = FCBType then
  try
{$IFDEF WIN32}
    Result := FCallbackEvent(CBInfo);
{$ELSE}
    Result := FCallbackEvent(@CBInfo);
{$ENDIF}
  except
    Application.HandleException(Self);
  end;
  if Assigned(FOldCBFunc) and (FChain = dcChain) then
    Result := pfDBICallBack(FOldCBFunc)(CallType, FOldCBData, CBInfo);
end;

{ ProgressList }

const
  ProgressList: TList = nil;

procedure SetWaitCursor;
begin
{$IFDEF WIN32}
  if (GetCurrentThreadID = MainThreadID) then
{$ENDIF}
    Screen.Cursor := TDBProgress(ProgressList.Items[
      ProgressList.Count - 1]).WaitCursor;
end;

procedure AddProgress(Progress: TDBProgress);
begin
  if ProgressList = nil then ProgressList := TList.Create;
  if ProgressList.IndexOf(Progress) = -1 then ProgressList.Add(Progress);
end;

procedure RemoveProgress(Progress: TDBProgress);
begin
  if ProgressList <> nil then begin
    ProgressList.Remove(Progress);
    if ProgressList.Count = 0 then begin
      ProgressList.Free;
      ProgressList := nil;
      Screen.Cursor := crDefault;
    end;
  end;
end;

{$IFDEF WIN32}

{ TSessionLink }

type
  TSessionLink = class(TDatabase)
  private
    FProgress: TDBProgress;
  public
    destructor Destroy; override;
  end;

destructor TSessionLink.Destroy;
begin
  if FProgress <> nil then begin
    FProgress.FSessionLink := nil;
    FProgress.Trace := False;
    FProgress.Active := False;
  end;
  inherited Destroy;
end;

{$ENDIF WIN32}

{ TDBProgress }

constructor TDBProgress.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FWaitCursor := crHourGlass;
  FActive := True;
end;

destructor TDBProgress.Destroy;
begin
{$IFDEF WIN32}
  FOnTrace := nil;
  Trace := False;
{$ENDIF}
  Active := False;
  FreeTimer;
  FTimer.Free;
  inherited Destroy;
end;

procedure TDBProgress.Loaded;
begin
  inherited Loaded;
  FStreamedValue := True;
  try
    SetActive(FActive);
{$IFDEF WIN32}