608 lines
16 KiB
ObjectPascal
608 lines
16 KiB
ObjectPascal
{-----------------------------------------------------------------------------
|
|
The contents of this file are subject to the Mozilla Public License
|
|
Version 1.1 (the "License"); you may not use this file except in compliance
|
|
with the License. You may obtain a copy of the License at
|
|
http://www.mozilla.org/MPL/MPL-1.1.html
|
|
|
|
Software distributed under the License is distributed on an "AS IS" basis,
|
|
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
|
|
the specific language governing rights and limitations under the License.
|
|
|
|
The Original Code is: JvDbPrgrss.PAS, released on 2002-07-04.
|
|
|
|
The Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev
|
|
Copyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev
|
|
Copyright (c) 2001,2002 SGB Software
|
|
All Rights Reserved.
|
|
|
|
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
|
|
located at http://jvcl.sourceforge.net
|
|
|
|
Known Issues:
|
|
-----------------------------------------------------------------------------}
|
|
// $Id: JvBDEProgress.pas 10612 2006-05-19 19:04:09Z jfudickar $
|
|
|
|
unit JvBDEProgress;
|
|
|
|
{$I jvcl.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFDEF UNITVERSIONING}
|
|
JclUnitVersioning,
|
|
{$ENDIF UNITVERSIONING}
|
|
Windows, Classes, Controls, DB, DBTables, Bde,
|
|
{$IFDEF COMPILER10_UP}
|
|
DBCommonTypes,
|
|
{$ENDIF COMPILER10_UP}
|
|
JvTimer, JvComponentBase;
|
|
|
|
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;
|
|
TOnTraceEvent = procedure(Sender: TObject; Flag: TTraceFlag; const Msg: string) of object;
|
|
|
|
TJvDBProgress = class(TJvComponent)
|
|
private
|
|
FActive: Boolean;
|
|
FStartTime: Longint;
|
|
FTimer: TJvTimer;
|
|
FWaitCursor: TCursor;
|
|
FGauge: TControl;
|
|
FMessageControl: TControl;
|
|
FStreamedValue: Boolean;
|
|
FGenProgressCallback: TObject;
|
|
FQryProgressCallback: TObject;
|
|
FOnMessageChange: TOnMessageChange;
|
|
FOnPercentChange: TOnPercentChange;
|
|
FOnProgress: TOnProgressEvent;
|
|
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;
|
|
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;
|
|
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;
|
|
property OnMessageChange: TOnMessageChange read FOnMessageChange write FOnMessageChange;
|
|
property OnPercentChange: TOnPercentChange read FOnPercentChange write FOnPercentChange;
|
|
property OnProgress: TOnProgressEvent read FOnProgress write FOnProgress;
|
|
end;
|
|
|
|
TJvDBCallbackEvent = function(CBInfo: Pointer): CBRType of object;
|
|
TJvDBCallbackChain = (dcOnlyOnce, dcChain, dcReplace);
|
|
|
|
TJvDBCallback = class(TObject)
|
|
private
|
|
FOwner: TObject;
|
|
FCBType: CBType;
|
|
FCBBuf: Pointer;
|
|
FCBBufLen: Cardinal;
|
|
FOldCBData: Longint;
|
|
FOldCBBuf: Pointer;
|
|
FOldCBBufLen: Word;
|
|
FOldCBFunc: Pointer;
|
|
FInstalled: Boolean;
|
|
FChain: TJvDBCallbackChain;
|
|
FCallbackEvent: TJvDBCallbackEvent;
|
|
protected
|
|
function Invoke(CallType: CBType; var CBInfo: Pointer): CBRType;
|
|
public
|
|
constructor Create(AOwner: TObject; CBType: CBType;
|
|
CBBufSize: Cardinal; CallbackEvent: TJvDBCallbackEvent;
|
|
Chain: TJvDBCallbackChain);
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
{$IFDEF UNITVERSIONING}
|
|
const
|
|
UnitVersioning: TUnitVersionInfo = (
|
|
RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/tags/JVCL3_32/run/JvBDEProgress.pas $';
|
|
Revision: '$Revision: 10612 $';
|
|
Date: '$Date: 2006-05-19 21:04:09 +0200 (ven., 19 mai 2006) $';
|
|
LogPath: 'JVCL\run'
|
|
);
|
|
{$ENDIF UNITVERSIONING}
|
|
|
|
implementation
|
|
|
|
uses
|
|
SysUtils, Math, Forms, StdCtrls,
|
|
JvProgressUtils;
|
|
|
|
const
|
|
cbQRYPROGRESS = cbRESERVED4;
|
|
|
|
function BdeCallBack(CallType: CBType; Data: Longint; CBInfo: Pointer): CBRType; stdcall;
|
|
begin
|
|
if Data <> 0 then
|
|
Result := TJvDBCallback(Data).Invoke(CallType, CBInfo)
|
|
else
|
|
Result := cbrUSEDEF;
|
|
end;
|
|
|
|
//=== { TJvDBCallback } ======================================================
|
|
|
|
constructor TJvDBCallback.Create(AOwner: TObject; CBType: CBType;
|
|
CBBufSize: Cardinal; CallbackEvent: TJvDBCallbackEvent;
|
|
Chain: TJvDBCallbackChain);
|
|
begin
|
|
inherited Create;
|
|
FOwner := AOwner;
|
|
FCBType := CBType;
|
|
FCallbackEvent := CallbackEvent;
|
|
DbiGetCallBack(nil, FCBType, @FOldCBData, @FOldCBBufLen, @FOldCBBuf,
|
|
pfDBICallBack(FOldCBFunc));
|
|
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 TJvDBCallback.Destroy;
|
|
begin
|
|
if FInstalled then
|
|
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);
|
|
if FCBBuf <> nil then
|
|
FreeMem(FCBBuf, FCBBufLen);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TJvDBCallback.Invoke(CallType: CBType; var CBInfo: Pointer): CBRType;
|
|
begin
|
|
Result := cbrUSEDEF;
|
|
if CallType = FCBType then
|
|
try
|
|
Result := FCallbackEvent(CBInfo);
|
|
except
|
|
Application.HandleException(Self);
|
|
end;
|
|
if Assigned(FOldCBFunc) and (FChain = dcChain) then
|
|
Result := pfDBICallBack(FOldCBFunc)(CallType, FOldCBData, CBInfo);
|
|
end;
|
|
|
|
var
|
|
ProgressList: TList = nil;
|
|
|
|
procedure SetWaitCursor;
|
|
begin
|
|
if GetCurrentThreadID = MainThreadID then
|
|
Screen.Cursor :=
|
|
TJvDBProgress(ProgressList.Items[ProgressList.Count - 1]).WaitCursor;
|
|
end;
|
|
|
|
procedure AddProgress(Progress: TJvDBProgress);
|
|
begin
|
|
if ProgressList = nil then
|
|
ProgressList := TList.Create;
|
|
if ProgressList.IndexOf(Progress) = -1 then
|
|
ProgressList.Add(Progress);
|
|
end;
|
|
|
|
procedure RemoveProgress(Progress: TJvDBProgress);
|
|
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;
|
|
|
|
//=== { TJvSessionLink } =====================================================
|
|
|
|
type
|
|
TJvSessionLink = class(TDatabase)
|
|
private
|
|
FProgress: TJvDBProgress;
|
|
public
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
destructor TJvSessionLink.Destroy;
|
|
begin
|
|
if FProgress <> nil then
|
|
begin
|
|
FProgress.FSessionLink := nil;
|
|
FProgress.Trace := False;
|
|
FProgress.Active := False;
|
|
end;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
//=== { TJvDBProgress } ======================================================
|
|
|
|
constructor TJvDBProgress.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FWaitCursor := crHourGlass;
|
|
FActive := True;
|
|
end;
|
|
|
|
destructor TJvDBProgress.Destroy;
|
|
begin
|
|
FOnTrace := nil;
|
|
Trace := False;
|
|
Active := False;
|
|
FreeTimer;
|
|
FTimer.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TJvDBProgress.Loaded;
|
|
begin
|
|
inherited Loaded;
|
|
FStreamedValue := True;
|
|
try
|
|
SetActive(FActive);
|
|
SetTrace(FTrace);
|
|
finally
|
|
FStreamedValue := False;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvDBProgress.TimerExpired(Sender: TObject);
|
|
begin
|
|
FreeTimer;
|
|
SetPercent(0);
|
|
SetMessage('');
|
|
end;
|
|
|
|
procedure TJvDBProgress.FreeTimer;
|
|
begin
|
|
if FTimer <> nil then
|
|
begin
|
|
FTimer.Enabled := False;
|
|
FStartTime := 0;
|
|
end;
|
|
Screen.Cursor := crDefault;
|
|
SetCursor(Screen.Cursors[crDefault]); { force update cursor }
|
|
end;
|
|
|
|
procedure TJvDBProgress.StartTimer;
|
|
begin
|
|
if FTimer = nil then
|
|
begin
|
|
FTimer := TJvTimer.Create(Self);
|
|
FTimer.Interval := 500;
|
|
end;
|
|
with FTimer do
|
|
begin
|
|
if not Enabled then
|
|
FStartTime := GetTickCount;
|
|
OnTimer := TimerExpired;
|
|
Enabled := True;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvDBProgress.SetPercent(Value: Integer);
|
|
begin
|
|
if Gauge <> nil then
|
|
begin
|
|
SetProgressMax(Gauge, 100);
|
|
SetProgressValue(Gauge, Value);
|
|
end;
|
|
if Assigned(FOnPercentChange) then
|
|
FOnPercentChange(Self, Value);
|
|
end;
|
|
|
|
procedure TJvDBProgress.SetMessage(const Value: string);
|
|
begin
|
|
if MessageControl <> nil then
|
|
begin
|
|
TLabel(MessageControl).Caption := Value;
|
|
MessageControl.Refresh;
|
|
end;
|
|
if Assigned(FOnMessageChange) then
|
|
FOnMessageChange(Self, Value);
|
|
end;
|
|
|
|
procedure TJvDBProgress.SetActive(Value: Boolean);
|
|
begin
|
|
if (FActive <> Value) or FStreamedValue then
|
|
begin
|
|
if not (csDesigning in ComponentState) then
|
|
begin
|
|
if Value then
|
|
AddProgress(Self)
|
|
else
|
|
RemoveProgress(Self);
|
|
if (FGenProgressCallback = nil) and Value then
|
|
begin
|
|
Activate;
|
|
FGenProgressCallback := TJvDBCallback.Create(Self, cbGENPROGRESS,
|
|
Max(SizeOf(CBPROGRESSDesc), SizeOf(DBIPATH) + SizeOf(Integer) * 4),
|
|
GenProgressCallback, dcChain);
|
|
FQryProgressCallback := TJvDBCallback.Create(Self, cbQRYPROGRESS,
|
|
SizeOf(DBIQryProgress), QryProgressCallback, dcChain);
|
|
end
|
|
else
|
|
if not Value and (FGenProgressCallback <> nil) then
|
|
begin
|
|
Sessions.CurrentSession := GetDBSession;
|
|
FGenProgressCallback.Free;
|
|
FGenProgressCallback := nil;
|
|
FQryProgressCallback.Free;
|
|
FQryProgressCallback := nil;
|
|
FreeTimer;
|
|
if not Trace then
|
|
Deactivate;
|
|
end;
|
|
end;
|
|
FActive := Value;
|
|
end;
|
|
end;
|
|
|
|
procedure TJvDBProgress.Activate;
|
|
var
|
|
S: TSession;
|
|
begin
|
|
if FSessionLink = nil then
|
|
begin
|
|
S := Sessions.List[SessionName];
|
|
S.Open;
|
|
Sessions.CurrentSession := S;
|
|
FSessionLink := TJvSessionLink.Create(S);
|
|
try
|
|
TJvSessionLink(FSessionLink).Temporary := True;
|
|
TJvSessionLink(FSessionLink).KeepConnection := False;
|
|
TJvSessionLink(FSessionLink).FProgress := Self;
|
|
except
|
|
FSessionLink.Free;
|
|
FSessionLink := nil;
|
|
raise;
|
|
end;
|
|
end
|
|
else
|
|
Sessions.CurrentSession := TDatabase(FSessionLink).Session;
|
|
end;
|
|
|
|
procedure TJvDBProgress.Deactivate;
|
|
begin
|
|
if FSessionLink <> nil then
|
|
begin
|
|
TJvSessionLink(FSessionLink).FProgress := nil;
|
|
FSessionLink.Free;
|
|
FSessionLink := nil;
|
|
end;
|
|
end;
|
|
|
|
function TJvDBProgress.GetDBSession: TSession;
|
|
begin
|
|
Result := Sessions.FindSession(SessionName);
|
|
if Result = nil then
|
|
Result := DBTables.Session;
|
|
end;
|
|
|
|
procedure TJvDBProgress.SetSessionName(const Value: string);
|
|
var
|
|
KeepActive, KeepTrace: Boolean;
|
|
begin
|
|
if Value <> SessionName then
|
|
if not (csDesigning in ComponentState) then
|
|
begin
|
|
KeepActive := Active;
|
|
KeepTrace := Trace;
|
|
Active := False;
|
|
Trace := False;
|
|
FSessionName := Value;
|
|
Active := KeepActive;
|
|
Trace := KeepTrace;
|
|
end
|
|
else
|
|
FSessionName := Value;
|
|
end;
|
|
|
|
procedure TJvDBProgress.SetTrace(Value: Boolean);
|
|
begin
|
|
if (FTrace <> Value) or (FStreamedValue and Value) then
|
|
if not (csDesigning in ComponentState) then
|
|
begin
|
|
if Value then
|
|
begin
|
|
Activate;
|
|
GetDBSession.TraceFlags := FTraceFlags;
|
|
FTraceCallback := TJvDBCallback.Create(Self, cbTRACE,
|
|
smTraceBufSize, TraceCallBack, dcReplace);
|
|
end
|
|
else
|
|
if FTraceCallback <> nil then
|
|
begin
|
|
Sessions.CurrentSession := GetDBSession;
|
|
FTraceCallback.Free;
|
|
FTraceCallback := nil;
|
|
if not Active then
|
|
Deactivate;
|
|
end;
|
|
FTrace := (FTraceCallback <> nil);
|
|
end
|
|
else
|
|
FTrace := Value;
|
|
end;
|
|
|
|
procedure TJvDBProgress.SetTraceFlags(Value: TTraceFlags);
|
|
begin
|
|
FTraceFlags := Value;
|
|
if Trace then
|
|
GetDBSession.TraceFlags := FTraceFlags;
|
|
end;
|
|
|
|
function TJvDBProgress.TraceCallBack(CBInfo: Pointer): CBRType;
|
|
var
|
|
CurFlag: TTraceFlag;
|
|
begin
|
|
Result := cbrUSEDEF;
|
|
if Trace and Assigned(FOnTrace) then
|
|
begin
|
|
case PTraceDesc(CBInfo)^.eTraceCat of
|
|
traceQPREPARE:
|
|
CurFlag := tfQPrepare;
|
|
traceQEXECUTE:
|
|
CurFlag := tfQExecute;
|
|
traceERROR:
|
|
CurFlag := tfError;
|
|
traceSTMT:
|
|
CurFlag := tfStmt;
|
|
traceCONNECT:
|
|
CurFlag := tfConnect;
|
|
traceTRANSACT:
|
|
CurFlag := tfTransact;
|
|
traceBLOB:
|
|
CurFlag := tfBlob;
|
|
traceMISC:
|
|
CurFlag := tfMisc;
|
|
traceVENDOR:
|
|
CurFlag := tfVendor;
|
|
traceDATAIN:
|
|
CurFlag := tfDataIn;
|
|
traceDATAOUT:
|
|
CurFlag := tfDataOut;
|
|
else
|
|
Exit;
|
|
end;
|
|
if CurFlag in TraceFlags then
|
|
FOnTrace(Self, CurFlag, StrPas(PTraceDesc(CBInfo)^.pszTrace));
|
|
end;
|
|
end;
|
|
|
|
procedure TJvDBProgress.SetMessageControl(Value: TControl);
|
|
begin
|
|
FMessageControl := Value;
|
|
if Value <> nil then
|
|
Value.FreeNotification(Self);
|
|
end;
|
|
|
|
procedure TJvDBProgress.SetGauge(Value: TControl);
|
|
begin
|
|
FGauge := Value;
|
|
if Value <> nil then
|
|
Value.FreeNotification(Self);
|
|
end;
|
|
|
|
procedure TJvDBProgress.Notification(AComponent: TComponent; AOperation: TOperation);
|
|
begin
|
|
inherited Notification(AComponent, AOperation);
|
|
if AOperation = opRemove then
|
|
if AComponent = Gauge then
|
|
Gauge := nil
|
|
else
|
|
if AComponent = MessageControl then
|
|
MessageControl := nil;
|
|
end;
|
|
|
|
function TJvDBProgress.GenProgressCallback(CBInfo: Pointer): CBRType;
|
|
var
|
|
CallInfo: pCBPROGRESSDesc;
|
|
AbortOp: Boolean;
|
|
begin
|
|
CallInfo := CBInfo;
|
|
Result := cbrUSEDEF;
|
|
StartTimer;
|
|
if (FTimer <> nil) and FTimer.Enabled {and (GetTickCount > FStartTime)} then
|
|
SetWaitCursor;
|
|
if Assigned(FOnProgress) then
|
|
begin
|
|
AbortOp := False;
|
|
FOnProgress(Self, AbortOp);
|
|
if AbortOp then
|
|
Result := cbrABORT;
|
|
end;
|
|
if CallInfo^.iPercentDone >= 0 then
|
|
SetPercent(CallInfo^.iPercentDone)
|
|
else
|
|
SetMessage(StrPas(CallInfo^.szMsg));
|
|
end;
|
|
|
|
function TJvDBProgress.QryProgressCallback(CBInfo: Pointer): CBRType;
|
|
var
|
|
CallInfo: pDBIQryProgress;
|
|
AbortOp: Boolean;
|
|
PcntDone: Double;
|
|
begin
|
|
CallInfo := CBInfo;
|
|
Result := cbrUSEDEF;
|
|
StartTimer;
|
|
{if (FTimer <> nil) and FTimer.Enabled then SetWaitCursor;}
|
|
if Assigned(FOnProgress) then
|
|
begin
|
|
AbortOp := False;
|
|
FOnProgress(Self, AbortOp);
|
|
if AbortOp then
|
|
Result := cbrABORT;
|
|
end;
|
|
with CallInfo^ do
|
|
PcntDone := (stepsCompleted / Max(1, stepsInQry)) *
|
|
(elemCompleted / Max(1, totElemInStep));
|
|
SetPercent(Round(PcntDone * 100));
|
|
end;
|
|
|
|
function TJvDBProgress.ProgressMsgValue(const Msg: string): Longint;
|
|
begin
|
|
if Msg <> '' then
|
|
Result := StrToIntDef(Trim(Copy(Msg, Pos(':', Msg) + 1, MaxInt)), -1)
|
|
else
|
|
Result := -1;
|
|
end;
|
|
|
|
{$IFDEF UNITVERSIONING}
|
|
initialization
|
|
RegisterUnitVersion(HInstance, UnitVersioning);
|
|
|
|
finalization
|
|
UnregisterUnitVersion(HInstance);
|
|
{$ENDIF UNITVERSIONING}
|
|
|
|
end.
|
|
|