childwin.pas

RxRich很有用的文字图像显示控件,这是它的Demo

  Db: TDatabase;
begin
  Result := False;
  Db := SessionDB(ASession);
  if Db <> nil then begin
    InTransNow := TransActive(Db);
    { Reading Database.InTransaction property causes change of current BDE session }
    case Operation of
      teStart: Result := not InTransNow;
      teCommit: Result := InTransNow;
      teRollback: Result := InTransNow;
    end;
  end;
end;

procedure TMDIChild.StartTransaction(ASession: TTransSession);
begin
  if TransOperEnabled(ASession, teStart) then
    with SessionDB(ASession) do begin
      if not IsSQLBased then TransIsolation := tiDirtyRead;
      StartTransaction;
    end;
  TDBExplorerMainForm(Application.MainForm).UpdateMenus;
end;

procedure TMDIChild.Commit(ASession: TTransSession);
begin
  if TransOperEnabled(ASession, teCommit) then
  try
    SessionDB(ASession).Commit;
    MessageDlg(SCommited, mtInformation, [mbOk], 0);
  finally
    TDBExplorerMainForm(Application.MainForm).UpdateMenus;
  end;
end;

procedure TMDIChild.Rollback(ASession: TTransSession);
begin
  if TransOperEnabled(ASession, teRollback) then
  try
    SessionDB(ASession).Rollback;
  finally
    TDBExplorerMainForm(Application.MainForm).UpdateMenus;
  end;
end;

procedure TMDIChild.CheckAndRepairParadoxTable(AllTables: Boolean);
var
  KeepActive: Boolean;
  FullName: string;
begin
  if (not CheckStandard) or (not TableList.Active) then
    DatabaseError(SSqlDatabase);
  KeepActive := Table1.Active;
  if (not KeepActive) and (not FTryOpenTable) then begin
    Table1.DisableControls;
    try
      try
        SetToCurrentTable;
      except
        { ignore exceptions }
      end;
      CloseCurrent;
    finally
      Table1.EnableControls;
    end;
  end;
  CloseCurrent;
  if not FQueryRunning then Query1.Close;
  try
    if AllTables then begin
      CheckTables(DatabaseName, crConfirmRepair);
      MessageDlg(SCheckComplete, mtInformation, [mbOk], 0);
    end
    else begin
      FullName := DatabaseName;
      if not IsDirectory(FullName) then FullName := GetAliasPath(FullName);
      FullName := NormalDir(FullName) + TableListTABNAME.AsString;
      CheckTable(FullName, crConfirmRepair);
    end;
  finally
    if KeepActive then SetToCurrentTable;
  end;
end;

{$IFDEF USE_QR2}
function FindPreview(AOwner: TComponent): TForm;
var
  I: Integer;
begin
  Result := nil;
  for I := 0 to Screen.FormCount - 1 do begin
    if (Screen.Forms[I] is TQRStandardPreview) and
      (Screen.Forms[I].Tag = Longint(Pointer(AOwner))) then
    begin
      Result := Screen.Forms[I];
      Exit;
    end;
  end;
end;
{$ENDIF USE_QR2}

procedure TMDIChild.PrintCurrentTable;
{$IFDEF USE_QR2}
var
  F: TForm;
{$ENDIF USE_QR2}
begin
{$IFDEF USE_QR2}
  if (DataSource.DataSet <> nil) then begin
    if DataSource.DataSet.Active then DataSource.DataSet.CheckBrowseMode
    else _DBError(SDataSetClosed);
    F := FindPreview(Self);
    if F <> nil then F.Close;
    with TQRDataSetBuilder.Create(Self) do
    try
      DataSet := Self.DataSource.DataSet;
      Active := True;
      Title := 'Report';
      Report.Preview;
    finally
      Free;
    end;
  end;
{$ELSE}
  NotImplemented;
{$ENDIF USE_QR2}
end;

procedure TMDIChild.ExportCurrentTable;
var
  DestName: string;
  TabType: TTableType;
  RecCount: Longint;
  DestTable: TTable;
begin
  if (DataSource.DataSet <> nil) then begin
    if DataSource.DataSet.Active then DataSource.DataSet.CheckBrowseMode;
    if (DataSource.DataSet is TTable) then begin
      DestName := ExtractFileName(TTable(DataSource.DataSet).TableName);
      if not CheckStandard then begin
        if Pos('.', DestName) > 0 then
          DestName := Copy(DestName, Pos('.', DestName) + 1, MaxInt);
        if DestName = '' then DestName := '$table';
      end;
    end
    else begin
      if not DataSource.DataSet.Active then _DBError(SDataSetClosed);
      DestName := 'Query';
    end;
  end;
  TabType := ttDefault;
  RecCount := 0;
  if not GetDestTable(DestName, TabType, RecCount) then Exit;
  Update;
  DestTable := TTable.Create(Self);
  try
    DestTable.TableName := DestName;
    ExportDataSet(DataSource.DataSet as TBDEDataSet, DestTable, TabType,
      ASCIICharSet, ASCIIDelimited, RecCount);
    MessageDlg(Format(STabCreated, [DestTable.TableName]),
      mtInformation, [mbOk], 0);
  finally
    DestTable.Free;
  end;
end;

procedure TMDIChild.ImportToCurrentTable;
var
  DestTable: TTable;
  SrcName: string;
  MaxRecCnt: Longint;
  BatchMode: TBatchMode;
  Mappings: TStrings;
  SrcTable: TTable;
begin
  DestTable := CurrentTable;
  if DestTable <> nil then begin
    Mappings := TStringList.Create;
    DestTable.DisableControls;
    try
      if GetImportParams(DestTable, SrcName, MaxRecCnt, Mappings,
        BatchMode) then
      begin
        SrcTable := TTable.Create(Self);
        try
          SrcTable.TableName := SrcName;
          ImportDataSet(SrcTable, DestTable, MaxRecCnt, Mappings, BatchMode);
        finally
          SrcTable.Free;
        end;
      end;
    finally
      Mappings.Free;
      DestTable.EnableControls;
    end;
  end;
end;

procedure TMDIChild.InternalOpenCurrent(const TabName: string);
var
  I: Integer;
begin
  FieldList1.TableName := TabName;
  IndexList1.TableName := TabName;
  RefIntList.TableName := TabName;
  try
    if not Table1.Active then Table1.TableName := TabName;
    FTryOpenTable := True;
    try
      Table1.Open;
    except
      on E: EDBEngineError do begin
        if E.Errors[0].ErrorCode = DBIERR_NOSUCHTABLE then
          MarkAsDeleted(TabName);
        raise;
      end;
      else raise;
    end;
    I := FDeletedList.IndexOf(TabName);
    if I >= 0 then begin
      FDeletedList.Delete(I);
      TableList.UpdateCursorPos;
      TableList.Resync([rmExact]);
    end;
    FieldList1.Open;
    IndexList1.Open;
    if (DataSource2.DataSet = RefIntList) then
      RefIntList.Open;
  except
    CloseCurrent;
    raise;
  end;
end;

procedure TMDIChild.ReindexTable;
var
  Val: string;
begin
  if DataSource.DataSet = nil then Exit;
  StartWait;
  DataSource.DataSet.DisableControls;
  try
    CloseCurrent;
    if TableList.Active then begin
      Val := TableListTABNAME.AsString;
      if Table1.TableName <> Val then Table1.TableName := Val;
      if Val <> '' then
      try
        BdeUtils.ReindexTable(Table1);
      finally
        InternalOpenCurrent(Val);
      end;
    end;
  finally
    DataSource.DataSet.EnableControls;
    StopWait;
  end;
end;

procedure TMDIChild.PackCurrentTable;
var
  Val: string;
begin
  StartWait;
  DataSource.DataSet.DisableControls;
  try
    CloseCurrent;
    if TableList.Active then begin
      Val := TableListTABNAME.AsString;
      if Table1.TableName <> Val then Table1.TableName := Val;
      if Val <> '' then begin
        Table1.Open;
        try
          PackTable(Table1);
        except
          Application.HandleException(Self);
        end;
        InternalOpenCurrent(Val);
      end;
    end;
  finally
    DataSource.DataSet.EnableControls;
    StopWait;
  end;
end;

procedure TMDIChild.CloseCurrent;
begin
  Table1.Close;
  FieldList1.Close;
  IndexList1.Close;
  RefIntList.Close;
end;

procedure TMDIChild.SetToCurrentTable;
var
  Val: string;
begin
  if DataSource.DataSet <> nil then
    DataSource.DataSet.DisableControls;
  StartWait;
  try
    CloseCurrent;
    if TableList.Active then begin
      Val := TableListTABNAME.AsString;
      if Table1.TableName <> Val then Table1.TableName := Val;
      if Val <> '' then InternalOpenCurrent(Val);
    end;
  finally
    StopWait;
    if DataSource.DataSet <> nil then
      DataSource.DataSet.EnableControls;
  end;
end;

procedure TMDIChild.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action := caFree;
end;

procedure TMDIChild.DataSource1DataChange(Sender: TObject; Field: TField);
begin
  if AutoActivate then SetToCurrentTable;
end;

procedure TMDIChild.Notebook1PageChanged(Sender: TObject);
begin
  TDBExplorerMainForm(Application.MainForm).UpdateMenus;
end;

procedure TMDIChild.TabSet1Change(Sender: TObject; NewTab: Integer;
  var AllowChange: Boolean);
var
  KeepPage: Integer;
  KeepDS: TDataSet;
begin
  KeepPage := Notebook1.PageIndex;
  KeepDS := DataSource2.DataSet;
  AllowChange := True;
  try
    case NewTab of
      0: begin
           Notebook1.PageIndex := 0;
           DataSource2.DataSet := Table1;
         end;
      1: begin
           Notebook1.PageIndex := 0;
           DataSource2.DataSet := FieldList1;
         end;
      2: begin
           Notebook1.PageIndex := 0;
           DataSource2.DataSet := IndexList1;
         end;
      3: begin
           Notebook1.PageIndex := 0;
           if (RefIntList.TableName = Table1.TableName) and Table1.Active then
           begin
             StartWait;
             try
               RefIntList.Open;
             finally
               StopWait;
             end;
           end;
           DataSource2.DataSet := RefIntList;
         end;
      4: begin
           Notebook1.PageIndex := 1;
           if DataSource3.DataSet <> Query1 then
             DataSource3.DataSet := Query1;
         end;
    end;
  except
    AllowChange := False;
    Notebook1.PageIndex := KeepPage;
    DataSource2.DataSet := KeepDS;
    raise;
  end;
end;

procedure TMDIChild.TableListCalcFields(DataSet: TDataset);
begin
  TableListTABNAME.AsString := TableList.ItemName;
  TableListDELETED.AsBoolean :=
    FDeletedList.IndexOf(TableListTABNAME.AsString) >= 0;
end;

procedure TMDIChild.RefIntListTYPEGetText(Sender: TField; var Text: string;
  DisplayText: Boolean);
begin
  case RINTType(Sender.AsInteger) of
    rintMASTER: Text := 'Master';
    rintDEPENDENT: Text := 'Dependent';
    else Text := '';
  end;
end;

procedure TMDIChild.StartWatch;
begin
  if FQueryRunning then SysUtils.Abort;
  FQueryStartTime := GetTickCount;
end;

procedure TMDIChild.StopWatch;
var
  H, M, S, MS: Longint;
begin
  if (Query1.OpenStatus in [qsExecuted, qsOpened]) and
    (FQueryStartTime > 0) then
  begin
    MS := GetTickCount - FQueryStartTime;
    S := MS div 1000;
    MS := MS - (1000 * S);
    M := S div 60;
    S := S - (M * 60);
    H := M div 60;
    M := M - (H * 60);
    FQueryStartTime := 0;
    Application.Restore;
    Application.BringToFront;
    if (M > 0) or (H > 0) then
      MessageDlg(Format('%s %s %d:%d:%d.', [SQuerySuccess, STimeElapsed,
        H, M, S]), mtInformation, [mbOk], 0)
    else
      MessageDlg(Format('%s %s %d:%d:%d.%.3d.', [SQuerySuccess, STimeElapsed,
        H, M, S, MS]), mtInformation, [mbOk], 0);
  end;
end;

procedure TMDIChild.ExecSQL;
begin
  StartWatch;
  StartWait;
  try
    if QueryInThreads then begin
      RunQuery1.Enabled := False;
      RunSQL.Enabled := False;
      FAbortQuery := False;
      FQueryRunning := True;
      with TRxQueryThread.Create(Query1, rqOpenOrExec, False, True) do begin
        OnTerminate := QueryThreadDone;
        DataSource3.DataSet := nil;
        CancelItem.Enabled := False;
        QueryAnimation.GlyphNum := 0;
        QueryAnimation.Hint := Format(SQueryHint, [DatabaseName]);
        QueryAnimation.Visible := True;
        QueryAnimation.Active := True;
        AbortQueryMenu.AutoPopup := AsyncQrySupported(QueryDB);
        Resume;
      end;
    end
    else Query1.OpenOrExec(True);
  finally
    StopWait;
  end;
  if not QueryInThreads then begin
    Application.ProcessMessages;
    if ShowExecTime then StopWatch
    else if (Query1.OpenStatus = qsExecuted) then begin
      MessageDlg(SQuerySuccess, mtInformation, [mbOk], 0);
    end
    else if (Query1.OpenStatus = qsOpened) and IsDataSetEmpty(Query1) then
    begin
      MessageDlg(SNoRows, mtInformation, [mbOk], 0);
    end;
  end;
end;

procedure TMDIChild.QueryThreadDone(Sender: TObject);
begin
  FQueryRunning := False;
  QueryAnimation.Active := False;
  QueryAnimation.Visible := False;
  FAbortQuery := False;
  CancelItem.Enabled := False;
  SQLMemoChange(nil);
  if DataSource3.DataSet = nil then
    DataSource3.DataSet := Query1;
  if Query1.OpenStatus in [qsExecuted, qsOpened] then MessageBeep(0);
  if ShowExecTime then StopWatch
  else if (Query1.OpenStatus = qsExecuted) or
    ((Query1.OpenStatus = qsOpened) and ((Notebook1.PageIndex <> 1) or
    (Application.MainForm.ActiveMDIChild <> Self))) then
  begin
    Application.ProcessMessages;
    MessageDlg(SQuerySuccess,  mtInformation, [mbOk], 0);
  end;
  FQueryStartTime := 0;
end;

procedure TMDIChild.RunQueryBuilder;
begin
{$IFDEF USE_VQB}
  if not VQBLoadAttempted and not VQBLoaded then begin
    StartWait;
    try
      InitVQB;
    finally