dbprgrss.pas

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

    SetTrace(FTrace);
{$ENDIF WIN32}
  finally
    FStreamedValue := False;
  end;
end;

procedure TDBProgress.TimerExpired(Sender: TObject);
begin
  FreeTimer;
  SetPercent(0);
  SetMessage('');
end;

procedure TDBProgress.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 TDBProgress.StartTimer;
begin
  if (FTimer = nil) then begin
    FTimer := TRxTimer.Create(Self);
    FTimer.Interval := 500;
  end;
  with FTimer do begin
    if not Enabled then FStartTime := GetTickCount;
    OnTimer := TimerExpired;
    Enabled := True;
  end;
end;

procedure TDBProgress.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 TDBProgress.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 TDBProgress.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
{$IFDEF WIN32}
        Activate;
{$ENDIF}
        FGenProgressCallback := TDBCallback.Create(Self, cbGENPROGRESS,
          Max(SizeOf(CBPROGRESSDesc), SizeOf(DBIPATH) + SizeOf(Integer) * 4),
          GenProgressCallback, dcChain);
        FQryProgressCallback := TDBCallback.Create(Self, cbQRYPROGRESS,
          SizeOf(DBIQryProgress), QryProgressCallback, dcChain);
      end
      else if not Value and (FGenProgressCallback <> nil) then begin
{$IFDEF WIN32}
        Sessions.CurrentSession := GetDBSession;
{$ENDIF}
        FGenProgressCallback.Free;
        FGenProgressCallback := nil;
        FQryProgressCallback.Free;
        FQryProgressCallback := nil;
        FreeTimer;
{$IFDEF WIN32}
        if not Trace then Deactivate;
{$ENDIF}
      end;
    end;
    FActive := Value;
  end;
end;

{$IFDEF WIN32}

procedure TDBProgress.Activate;
var
  S: TSession;
begin
  if FSessionLink = nil then begin
    S := Sessions.List[SessionName];
    S.Open;
    Sessions.CurrentSession := S;
    FSessionLink := TSessionLink.Create(S);
    try
      TSessionLink(FSessionLink).Temporary := True;
      TSessionLink(FSessionLink).KeepConnection := False;
      TSessionLink(FSessionLink).FProgress := Self;
    except
      FSessionLink.Free;
      FSessionLink := nil;
      raise;
    end;
  end
  else Sessions.CurrentSession := TDatabase(FSessionLink).Session;
end;

procedure TDBProgress.Deactivate;
begin
  if FSessionLink <> nil then begin
    TSessionLink(FSessionLink).FProgress := nil;
    FSessionLink.Free;
    FSessionLink := nil;
  end;
end;

function TDBProgress.GetDBSession: TSession;
begin
  Result := Sessions.FindSession(SessionName);
  if Result = nil then
{$IFDEF RX_D3}
    Result := DBTables.Session;
{$ELSE}
    Result := DB.Session;
{$ENDIF}
end;

procedure TDBProgress.SetSessionName(const Value: string);
var
  KeepActive, KeepTrace: Boolean;
begin
  if Value <> SessionName then begin
    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;
end;

procedure TDBProgress.SetTrace(Value: Boolean);
begin
  if (FTrace <> Value) or (FStreamedValue and Value) then begin
    if not (csDesigning in ComponentState) then begin
      if Value then begin
        Activate;
        GetDBSession.TraceFlags := FTraceFlags;
        FTraceCallback := TDBCallback.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;
end;

procedure TDBProgress.SetTraceFlags(Value: TTraceFlags);
begin
  FTraceFlags := Value;
  if Trace then GetDBSession.TraceFlags := FTraceFlags;
end;

function TDBProgress.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;
{$IFDEF RX_D3}
      traceDATAIN: CurFlag := tfDataIn;
      traceDATAOUT: CurFlag := tfDataOut;
{$ENDIF RX_D3}
      else Exit;
    end;
    if (CurFlag in TraceFlags) then
      FOnTrace(Self, CurFlag, StrPas(PTraceDesc(CBInfo)^.pszTrace));
  end;
end;

{$ENDIF WIN32}

procedure TDBProgress.SetMessageControl(Value: TControl);
begin
  FMessageControl := Value;
{$IFDEF WIN32}
  if Value <> nil then Value.FreeNotification(Self);
{$ENDIF}
end;

procedure TDBProgress.SetGauge(Value: TControl);
begin
  FGauge := Value;
{$IFDEF WIN32}
  if Value <> nil then Value.FreeNotification(Self);
{$ENDIF}
end;

procedure TDBProgress.Notification(AComponent: TComponent; AOperation: TOperation);
begin
  inherited Notification(AComponent, AOperation);
  if AOperation = opRemove then begin
    if AComponent = Gauge then Gauge := nil
    else if AComponent = MessageControl then MessageControl := nil;
  end;
end;

function TDBProgress.GenProgressCallback(CBInfo: Pointer): CBRType;
var
  CallInfo: pCBPROGRESSDesc absolute CBInfo;
  AbortOp: Boolean;
begin
  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 TDBProgress.QryProgressCallback(CBInfo: Pointer): CBRType;
var
  CallInfo: pDBIQryProgress absolute CBInfo;
  AbortOp: Boolean;
  PcntDone: Double;
begin
  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 begin
    PcntDone := (stepsCompleted / Max(1, stepsInQry)) *
      (elemCompleted / Max(1, totElemInStep));
  end;
  SetPercent(Round(PcntDone * 100));
end;

function TDBProgress.ProgressMsgValue(const Msg: string): Longint;
begin
  if Msg <> '' then
    Result := StrToIntDef(Trim(Copy(Msg, Pos(':', Msg) + 1, MaxInt)), -1)
  else Result := -1;
end;

end.