home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kolekce / d6 / RX275D6.ZIP / Units / DBPRGRSS.PAS < prev    next >
Pascal/Delphi Source File  |  1999-10-12  |  16KB  |  559 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {         Delphi VCL Extensions (RX)                    }
  4. {                                                       }
  5. {         Copyright (c) 1995, 1996 AO ROSNO             }
  6. {         Copyright (c) 1997 Master-Bank                }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit DbPrgrss;
  11.  
  12. interface
  13.  
  14. {$I RX.INC}
  15. {$T-}
  16.  
  17. uses Classes, {$IFDEF WIN32} Bde, {$ELSE} DbiTypes, DbiProcs, {$ENDIF WIN32}
  18.   Controls, DB, DBTables, RxTimer;
  19.  
  20. type
  21.   TOnMessageChange = procedure(Sender: TObject; const Msg: string) of object;
  22.   TOnPercentChange = procedure(Sender: TObject; PercentDone: Integer) of object;
  23.   TOnProgressEvent = procedure(Sender: TObject; var AbortQuery: Boolean) of object;
  24. {$IFDEF WIN32}
  25.   TOnTraceEvent = procedure(Sender: TObject; Flag: TTraceFlag;
  26.     const Msg: string) of object;
  27. {$ENDIF WIN32}
  28.  
  29. { TDBProgress }
  30.  
  31.   TDBProgress = class(TComponent)
  32.   private
  33.     FActive: Boolean;
  34.     FStartTime: Longint;
  35.     FTimer: TRxTimer;
  36.     FWaitCursor: TCursor;
  37.     FGauge: TControl;
  38.     FMessageControl: TControl;
  39.     FStreamedValue: Boolean;
  40.     FGenProgressCallback: TObject;
  41.     FQryProgressCallback: TObject;
  42.     FOnMessageChange: TOnMessageChange;
  43.     FOnPercentChange: TOnPercentChange;
  44.     FOnProgress: TOnProgressEvent;
  45. {$IFDEF WIN32}
  46.     FTraceFlags: TTraceFlags;
  47.     FTraceCallback: TObject;
  48.     FTrace: Boolean;
  49.     FOnTrace: TOnTraceEvent;
  50.     FSessionName: string;
  51.     FSessionLink: TObject;
  52.     procedure SetTrace(Value: Boolean);
  53.     procedure SetTraceFlags(Value: TTraceFlags);
  54.     function TraceCallBack(CBInfo: Pointer): CBRType;
  55.     function GetDBSession: TSession;
  56.     procedure SetSessionName(const Value: string);
  57.     procedure Activate;
  58.     procedure Deactivate;
  59. {$ENDIF WIN32}
  60.     procedure FreeTimer;
  61.     procedure StartTimer;
  62.     procedure TimerExpired(Sender: TObject);
  63.     function GenProgressCallback(CBInfo: Pointer): CBRType;
  64.     function QryProgressCallback(CBInfo: Pointer): CBRType;
  65.     procedure SetActive(Value: Boolean);
  66.     procedure SetPercent(Value: Integer);
  67.     procedure SetMessage(const Value: string);
  68.     procedure SetMessageControl(Value: TControl);
  69.     procedure SetGauge(Value: TControl);
  70.   protected
  71.     procedure Notification(AComponent: TComponent; AOperation: TOperation); override;
  72.     procedure Loaded; override;
  73.   public
  74.     constructor Create(AOwner: TComponent); override;
  75.     destructor Destroy; override;
  76.     function ProgressMsgValue(const Msg: string): Longint;
  77.   published
  78.     property Active: Boolean read FActive write SetActive default True;
  79.     property WaitCursor: TCursor read FWaitCursor write FWaitCursor default crHourGlass;
  80.     property MessageControl: TControl read FMessageControl write SetMessageControl;
  81.     property Gauge: TControl read FGauge write SetGauge;
  82. {$IFDEF WIN32}
  83.     property SessionName: string read FSessionName write SetSessionName;
  84.     property Trace: Boolean read FTrace write SetTrace default False;
  85.     property TraceFlags: TTraceFlags read FTraceFlags write SetTraceFlags default [];
  86.     property OnTrace: TOnTraceEvent read FOnTrace write FOnTrace;
  87. {$ENDIF WIN32}
  88.     property OnMessageChange: TOnMessageChange read FOnMessageChange write FOnMessageChange;
  89.     property OnPercentChange: TOnPercentChange read FOnPercentChange write FOnPercentChange;
  90.     property OnProgress: TOnProgressEvent read FOnProgress write FOnProgress;
  91.   end;
  92.  
  93. { TDBCallback - for internal use only }
  94.  
  95. type
  96.   TDBCallbackEvent = function(CBInfo: Pointer): CBRType of object;
  97.   TDBCallbackChain = (dcOnlyOnce, dcChain, dcReplace);
  98.  
  99.   TDBCallback = class(TObject)
  100.   private
  101.     FOwner: TObject;
  102.     FCBType: CBType;
  103.     FCBBuf: Pointer;
  104.     FCBBufLen: Cardinal;
  105.     FOldCBData: Longint;
  106.     FOldCBBuf: Pointer;
  107.     FOldCBBufLen: Word;
  108.     FOldCBFunc: Pointer;
  109.     FInstalled: Boolean;
  110.     FChain: TDBCallbackChain;
  111.     FCallbackEvent: TDBCallbackEvent;
  112.   protected
  113.     function Invoke(CallType: CBType; var CBInfo: Pointer): CBRType;
  114.   public
  115.     constructor Create(AOwner: TObject; CBType: CBType;
  116.       CBBufSize: Cardinal; CallbackEvent: TDBCallbackEvent;
  117.       Chain: TDBCallbackChain);
  118.     destructor Destroy; override;
  119.   end;
  120.  
  121. implementation
  122.  
  123. uses {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs, Str16, {$ENDIF WIN32}
  124.   Forms, SysUtils, StdCtrls, Dialogs, MaxMin, RxPrgrss, BdeUtils;
  125.  
  126. const
  127.   cbQRYPROGRESS = cbRESERVED4;
  128.  
  129. { TDBCallback }
  130.  
  131. function BdeCallBack(CallType: CBType; Data: Longint;
  132.   {$IFNDEF WIN32} var {$ENDIF} CBInfo: Pointer): CBRType;
  133.   {$IFDEF WIN32} stdcall; {$ELSE} export; {$ENDIF WIN32}
  134. begin
  135.   if Data <> 0 then begin
  136.     Result := TDBCallback(Data).Invoke(CallType, CBInfo);
  137.   end
  138.   else Result := cbrUSEDEF;
  139. end;
  140.  
  141. constructor TDBCallback.Create(AOwner: TObject; CBType: CBType;
  142.   CBBufSize: Cardinal; CallbackEvent: TDBCallbackEvent;
  143.   Chain: TDBCallbackChain);
  144. begin
  145.   FOwner := AOwner;
  146.   FCBType := CBType;
  147.   FCallbackEvent := CallbackEvent;
  148. {$IFDEF WIN32}
  149.   DbiGetCallBack(nil, FCBType, @FOldCBData, @FOldCBBufLen, @FOldCBBuf,
  150.     pfDBICallBack(FOldCBFunc));
  151. {$ELSE}
  152.   DbiGetCallBack(nil, FCBType, FOldCBData, FOldCBBufLen, FOldCBBuf,
  153.     @FOldCBFunc);
  154. {$ENDIF}
  155.   FChain := Chain;
  156.   if not Assigned(FOldCBFunc) then FOldCBBufLen := 0;
  157.   if not Assigned(FOldCBFunc) or (FChain in [dcChain, dcReplace]) then begin
  158.     FCBBufLen := Max(CBBufSize, FOldCBBufLen);
  159.     FCBBuf := AllocMem(FCBBufLen);
  160.     Check(DbiRegisterCallback(nil, FCBType, Longint(Self), FCBBufLen,
  161.       FCBBuf, BdeCallBack));
  162.     FInstalled := True;
  163.   end;
  164. end;
  165.  
  166. destructor TDBCallback.Destroy;
  167. begin
  168.   if FInstalled then begin
  169.     if Assigned(FOldCBFunc) and (FChain = dcChain) then
  170.     try
  171.       DbiRegisterCallback(nil, FCBType, FOldCBData, FOldCBBufLen,
  172.         FOldCBBuf, pfDBICallback(FOldCBFunc));
  173.     except
  174.     end
  175.     else DbiRegisterCallback(nil, FCBType, 0, 0, nil, nil);
  176.   end;
  177.   if FCBBuf <> nil then FreeMem(FCBBuf, FCBBufLen);
  178. end;
  179.  
  180. function TDBCallback.Invoke(CallType: CBType; var CBInfo: Pointer): CBRType;
  181. begin
  182.   Result := cbrUSEDEF;
  183.   if CallType = FCBType then
  184.   try
  185. {$IFDEF WIN32}
  186.     Result := FCallbackEvent(CBInfo);
  187. {$ELSE}
  188.     Result := FCallbackEvent(@CBInfo);
  189. {$ENDIF}
  190.   except
  191.     Application.HandleException(Self);
  192.   end;
  193.   if Assigned(FOldCBFunc) and (FChain = dcChain) then
  194.     Result := pfDBICallBack(FOldCBFunc)(CallType, FOldCBData, CBInfo);
  195. end;
  196.  
  197. { ProgressList }
  198.  
  199. const
  200.   ProgressList: TList = nil;
  201.  
  202. procedure SetWaitCursor;
  203. begin
  204. {$IFDEF WIN32}
  205.   if (GetCurrentThreadID = MainThreadID) then
  206. {$ENDIF}
  207.     Screen.Cursor := TDBProgress(ProgressList.Items[
  208.       ProgressList.Count - 1]).WaitCursor;
  209. end;
  210.  
  211. procedure AddProgress(Progress: TDBProgress);
  212. begin
  213.   if ProgressList = nil then ProgressList := TList.Create;
  214.   if ProgressList.IndexOf(Progress) = -1 then ProgressList.Add(Progress);
  215. end;
  216.  
  217. procedure RemoveProgress(Progress: TDBProgress);
  218. begin
  219.   if ProgressList <> nil then begin
  220.     ProgressList.Remove(Progress);
  221.     if ProgressList.Count = 0 then begin
  222.       ProgressList.Free;
  223.       ProgressList := nil;
  224.       Screen.Cursor := crDefault;
  225.     end;
  226.   end;
  227. end;
  228.  
  229. {$IFDEF WIN32}
  230.  
  231. { TSessionLink }
  232.  
  233. type
  234.   TSessionLink = class(TDatabase)
  235.   private
  236.     FProgress: TDBProgress;
  237.   public
  238.     destructor Destroy; override;
  239.   end;
  240.  
  241. destructor TSessionLink.Destroy;
  242. begin
  243.   if FProgress <> nil then begin
  244.     FProgress.FSessionLink := nil;
  245.     FProgress.Trace := False;
  246.     FProgress.Active := False;
  247.   end;
  248.   inherited Destroy;
  249. end;
  250.  
  251. {$ENDIF WIN32}
  252.  
  253. { TDBProgress }
  254.  
  255. constructor TDBProgress.Create(AOwner: TComponent);
  256. begin
  257.   inherited Create(AOwner);
  258.   FWaitCursor := crHourGlass;
  259.   FActive := True;
  260. end;
  261.  
  262. destructor TDBProgress.Destroy;
  263. begin
  264. {$IFDEF WIN32}
  265.   FOnTrace := nil;
  266.   Trace := False;
  267. {$ENDIF}
  268.   Active := False;
  269.   FreeTimer;
  270.   FTimer.Free;
  271.   inherited Destroy;
  272. end;
  273.  
  274. procedure TDBProgress.Loaded;
  275. begin
  276.   inherited Loaded;
  277.   FStreamedValue := True;
  278.   try
  279.     SetActive(FActive);
  280. {$IFDEF WIN32}
  281.     SetTrace(FTrace);
  282. {$ENDIF WIN32}
  283.   finally
  284.     FStreamedValue := False;
  285.   end;
  286. end;
  287.  
  288. procedure TDBProgress.TimerExpired(Sender: TObject);
  289. begin
  290.   FreeTimer;
  291.   SetPercent(0);
  292.   SetMessage('');
  293. end;
  294.  
  295. procedure TDBProgress.FreeTimer;
  296. begin
  297.   if FTimer <> nil then begin
  298.     FTimer.Enabled := False;
  299.     FStartTime := 0;
  300.   end;
  301.   Screen.Cursor := crDefault;
  302.   SetCursor(Screen.Cursors[crDefault]); { force update cursor }
  303. end;
  304.  
  305. procedure TDBProgress.StartTimer;
  306. begin
  307.   if (FTimer = nil) then begin
  308.     FTimer := TRxTimer.Create(Self);
  309.     FTimer.Interval := 500;
  310.   end;
  311.   with FTimer do begin
  312.     if not Enabled then FStartTime := GetTickCount;
  313.     OnTimer := TimerExpired;
  314.     Enabled := True;
  315.   end;
  316. end;
  317.  
  318. procedure TDBProgress.SetPercent(Value: Integer);
  319. begin
  320.   if Gauge <> nil then begin
  321.     SetProgressMax(Gauge, 100);
  322.     SetProgressValue(Gauge, Value);
  323.   end;
  324.   if Assigned(FOnPercentChange) then FOnPercentChange(Self, Value);
  325. end;
  326.  
  327. procedure TDBProgress.SetMessage(const Value: string);
  328. begin
  329.   if MessageControl <> nil then begin
  330.     TLabel(MessageControl).Caption := Value;
  331.     MessageControl.Refresh;
  332.   end;
  333.   if Assigned(FOnMessageChange) then FOnMessageChange(Self, Value);
  334. end;
  335.  
  336. procedure TDBProgress.SetActive(Value: Boolean);
  337. begin
  338.   if (FActive <> Value) or FStreamedValue then begin
  339.     if not (csDesigning in ComponentState) then begin
  340.       if Value then AddProgress(Self) else RemoveProgress(Self);
  341.       if (FGenProgressCallback = nil) and Value then begin
  342. {$IFDEF WIN32}
  343.         Activate;
  344. {$ENDIF}
  345.         FGenProgressCallback := TDBCallback.Create(Self, cbGENPROGRESS,
  346.           Max(SizeOf(CBPROGRESSDesc), SizeOf(DBIPATH) + SizeOf(Integer) * 4),
  347.           GenProgressCallback, dcChain);
  348.         FQryProgressCallback := TDBCallback.Create(Self, cbQRYPROGRESS,
  349.           SizeOf(DBIQryProgress), QryProgressCallback, dcChain);
  350.       end
  351.       else if not Value and (FGenProgressCallback <> nil) then begin
  352. {$IFDEF WIN32}
  353.         Sessions.CurrentSession := GetDBSession;
  354. {$ENDIF}
  355.         FGenProgressCallback.Free;
  356.         FGenProgressCallback := nil;
  357.         FQryProgressCallback.Free;
  358.         FQryProgressCallback := nil;
  359.         FreeTimer;
  360. {$IFDEF WIN32}
  361.         if not Trace then Deactivate;
  362. {$ENDIF}
  363.       end;
  364.     end;
  365.     FActive := Value;
  366.   end;
  367. end;
  368.  
  369. {$IFDEF WIN32}
  370.  
  371. procedure TDBProgress.Activate;
  372. var
  373.   S: TSession;
  374. begin
  375.   if FSessionLink = nil then begin
  376.     S := Sessions.List[SessionName];
  377.     S.Open;
  378.     Sessions.CurrentSession := S;
  379.     FSessionLink := TSessionLink.Create(S);
  380.     try
  381.       TSessionLink(FSessionLink).Temporary := True;
  382.       TSessionLink(FSessionLink).KeepConnection := False;
  383.       TSessionLink(FSessionLink).FProgress := Self;
  384.     except
  385.       FSessionLink.Free;
  386.       FSessionLink := nil;
  387.       raise;
  388.     end;
  389.   end
  390.   else Sessions.CurrentSession := TDatabase(FSessionLink).Session;
  391. end;
  392.  
  393. procedure TDBProgress.Deactivate;
  394. begin
  395.   if FSessionLink <> nil then begin
  396.     TSessionLink(FSessionLink).FProgress := nil;
  397.     FSessionLink.Free;
  398.     FSessionLink := nil;
  399.   end;
  400. end;
  401.  
  402. function TDBProgress.GetDBSession: TSession;
  403. begin
  404.   Result := Sessions.FindSession(SessionName);
  405.   if Result = nil then
  406. {$IFDEF RX_D3}
  407.     Result := DBTables.Session;
  408. {$ELSE}
  409.     Result := DB.Session;
  410. {$ENDIF}
  411. end;
  412.  
  413. procedure TDBProgress.SetSessionName(const Value: string);
  414. var
  415.   KeepActive, KeepTrace: Boolean;
  416. begin
  417.   if Value <> SessionName then begin
  418.     if not (csDesigning in ComponentState) then begin
  419.       KeepActive := Active;
  420.       KeepTrace := Trace;
  421.       Active := False;
  422.       Trace := False;
  423.       FSessionName := Value;
  424.       Active := KeepActive;
  425.       Trace := KeepTrace;
  426.     end
  427.     else FSessionName := Value;
  428.   end;
  429. end;
  430.  
  431. procedure TDBProgress.SetTrace(Value: Boolean);
  432. begin
  433.   if (FTrace <> Value) or (FStreamedValue and Value) then begin
  434.     if not (csDesigning in ComponentState) then begin
  435.       if Value then begin
  436.         Activate;
  437.         GetDBSession.TraceFlags := FTraceFlags;
  438.         FTraceCallback := TDBCallback.Create(Self, cbTRACE,
  439.           smTraceBufSize, TraceCallBack, dcReplace);
  440.       end
  441.       else if (FTraceCallback <> nil) then begin
  442.         Sessions.CurrentSession := GetDBSession;
  443.         FTraceCallback.Free;
  444.         FTraceCallback := nil;
  445.         if not Active then Deactivate;
  446.       end;
  447.       FTrace := (FTraceCallback <> nil);
  448.     end
  449.     else FTrace := Value;
  450.   end;
  451. end;
  452.  
  453. procedure TDBProgress.SetTraceFlags(Value: TTraceFlags);
  454. begin
  455.   FTraceFlags := Value;
  456.   if Trace then GetDBSession.TraceFlags := FTraceFlags;
  457. end;
  458.  
  459. function TDBProgress.TraceCallBack(CBInfo: Pointer): CBRType;
  460. var
  461.   CurFlag: TTraceFlag;
  462. begin
  463.   Result := cbrUSEDEF;
  464.   if Trace and Assigned(FOnTrace) then begin
  465.     case PTraceDesc(CBInfo)^.eTraceCat of
  466.       traceQPREPARE: CurFlag := tfQPrepare;
  467.       traceQEXECUTE: CurFlag := tfQExecute;
  468.       traceERROR: CurFlag := tfError;
  469.       traceSTMT: CurFlag := tfStmt;
  470.       traceCONNECT: CurFlag := tfConnect;
  471.       traceTRANSACT: CurFlag := tfTransact;
  472.       traceBLOB: CurFlag := tfBlob;
  473.       traceMISC: CurFlag := tfMisc;
  474.       traceVENDOR: CurFlag := tfVendor;
  475. {$IFDEF RX_D3}
  476.       traceDATAIN: CurFlag := tfDataIn;
  477.       traceDATAOUT: CurFlag := tfDataOut;
  478. {$ENDIF RX_D3}
  479.       else Exit;
  480.     end;
  481.     if (CurFlag in TraceFlags) then
  482.       FOnTrace(Self, CurFlag, StrPas(PTraceDesc(CBInfo)^.pszTrace));
  483.   end;
  484. end;
  485.  
  486. {$ENDIF WIN32}
  487.  
  488. procedure TDBProgress.SetMessageControl(Value: TControl);
  489. begin
  490.   FMessageControl := Value;
  491. {$IFDEF WIN32}
  492.   if Value <> nil then Value.FreeNotification(Self);
  493. {$ENDIF}
  494. end;
  495.  
  496. procedure TDBProgress.SetGauge(Value: TControl);
  497. begin
  498.   FGauge := Value;
  499. {$IFDEF WIN32}
  500.   if Value <> nil then Value.FreeNotification(Self);
  501. {$ENDIF}
  502. end;
  503.  
  504. procedure TDBProgress.Notification(AComponent: TComponent; AOperation: TOperation);
  505. begin
  506.   inherited Notification(AComponent, AOperation);
  507.   if AOperation = opRemove then begin
  508.     if AComponent = Gauge then Gauge := nil
  509.     else if AComponent = MessageControl then MessageControl := nil;
  510.   end;
  511. end;
  512.  
  513. function TDBProgress.GenProgressCallback(CBInfo: Pointer): CBRType;
  514. var
  515.   CallInfo: pCBPROGRESSDesc absolute CBInfo;
  516.   AbortOp: Boolean;
  517. begin
  518.   Result := cbrUSEDEF;
  519.   StartTimer;
  520.   if (FTimer <> nil) and FTimer.Enabled {and (GetTickCount > FStartTime)} then
  521.     SetWaitCursor;
  522.   if Assigned(FOnProgress) then begin
  523.     AbortOp := False;
  524.     FOnProgress(Self, AbortOp);
  525.     if AbortOp then Result := cbrABORT;
  526.   end;
  527.   if CallInfo^.iPercentDone >= 0 then SetPercent(CallInfo^.iPercentDone)
  528.   else SetMessage(StrPas(CallInfo^.szMsg));
  529. end;
  530.  
  531. function TDBProgress.QryProgressCallback(CBInfo: Pointer): CBRType;
  532. var
  533.   CallInfo: pDBIQryProgress absolute CBInfo;
  534.   AbortOp: Boolean;
  535.   PcntDone: Double;
  536. begin
  537.   Result := cbrUSEDEF;
  538.   StartTimer;
  539.   {if (FTimer <> nil) and FTimer.Enabled then SetWaitCursor;}
  540.   if Assigned(FOnProgress) then begin
  541.     AbortOp := False;
  542.     FOnProgress(Self, AbortOp);
  543.     if AbortOp then Result := cbrABORT;
  544.   end;
  545.   with CallInfo^ do begin
  546.     PcntDone := (stepsCompleted / Max(1, stepsInQry)) *
  547.       (elemCompleted / Max(1, totElemInStep));
  548.   end;
  549.   SetPercent(Round(PcntDone * 100));
  550. end;
  551.  
  552. function TDBProgress.ProgressMsgValue(const Msg: string): Longint;
  553. begin
  554.   if Msg <> '' then
  555.     Result := StrToIntDef(Trim(Copy(Msg, Pos(':', Msg) + 1, MaxInt)), -1)
  556.   else Result := -1;
  557. end;
  558.  
  559. end.