childwin.pas

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

unit ChildWin;

{$I RX.INC}

interface

uses WinTypes, WinProcs, Messages, Classes, Graphics, Forms, Controls, DB,
  DBLists, Tabs, ExtCtrls, RXSplit, DBTables, Grids, DBGrids, RXDBCtrl,
  RXQuery, StdCtrls, Buttons, Placemnt, DBIndex, DBSecur, Menus, Dialogs,
  RXShell, PicClip;

type
  TTransOperation = (teStart, teCommit, teRollback);

  TMDIChild = class(TForm)
    TableList: TDatabaseItems;
    DataSource1: TDataSource;
    TablesGrid: TrxDBGrid;
    rxSplitter1: TrxSplitter;
    Panel1: TPanel;
    Notebook1: TNotebook;
    TabSet1: TTabSet;
    FieldList1: TTableItems;
    IndexList1: TTableItems;
    DataSource2: TDataSource;
    Table1: TTable;
    rxDBGrid2: TrxDBGrid;
    Panel2: TPanel;
    SQLMemo: TMemo;
    Panel3: TPanel;
    RunSQL: TSpeedButton;
    Panel4: TPanel;
    Label1: TLabel;
    Panel5: TPanel;
    rxDBGrid3: TrxDBGrid;
    Query1: TrxQuery;
    TableListTABNAME: TStringField;
    TableListEXTENSION: TStringField;
    TableListTYPE: TStringField;
    FieldList1TYPE: TWordField;
    FieldList1SUBTYPE: TWordField;
    FieldList1UNITS1: TWordField;
    FieldList1UNITS2: TWordField;
    FieldList1LENGTH: TWordField;
    IndexList1TAGNAME: TStringField;
    IndexList1UNIQUE: TBooleanField;
    FieldList1TypeName: TStringField;
    FieldList1SubTypeName: TStringField;
    TableListPict: TBooleanField;
    TableListNAME: TStringField;
    FieldList1NAME: TStringField;
    IndexList1NAME: TStringField;
    FormStorage: TFormStorage;
    rxSplitter2: TrxSplitter;
    Panel6: TPanel;
    Panel7: TPanel;
    DBIndexCombo1: TDBIndexCombo;
    Label2: TLabel;
    PopupTablesMenu: TPopupMenu;
    FilterItem: TMenuItem;
    N1: TMenuItem;
    CloseItem: TMenuItem;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    TrayIconImage: TImage;
    TrayAbortImage: TImage;
    TrayMenu: TPopupMenu;
    CancelItem: TMenuItem;
    TableListVIEW: TBooleanField;
    PriorSQL: TSpeedButton;
    NextSQL: TSpeedButton;
    PopupSQLMenu: TPopupMenu;
    Undo1: TMenuItem;
    N2: TMenuItem;
    Cut1: TMenuItem;
    Copy1: TMenuItem;
    Paste1: TMenuItem;
    N3: TMenuItem;
    SelectAll1: TMenuItem;
    N4: TMenuItem;
    Saveas1: TMenuItem;
    Load1: TMenuItem;
    PriorSQLItem: TMenuItem;
    NextSQLItem: TMenuItem;
    Runquery1: TMenuItem;
    RefIntList: TTableItems;
    RefIntListNAME: TStringField;
    RefIntListOTHERTABLE: TStringField;
    RefIntListINTTYPE: TStringField;
    FieldList1Required: TBooleanField;
    CloseTableItem: TMenuItem;
    DbImages: TPicClip;
    IndexList1PRIMARY: TBooleanField;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure DataSource1DataChange(Sender: TObject; Field: TField);
    procedure TabSet1Change(Sender: TObject; NewTab: Integer;
      var AllowChange: Boolean);
    procedure TableListCalcFields(DataSet: TDataset);
    procedure RunSQLClick(Sender: TObject);
    procedure FieldList1CalcFields(DataSet: TDataset);
    procedure TablesGridDrawDataCell(Sender: TObject; const Rect: TRect;
      Field: TField; State: TGridDrawState);
    procedure TablesGridDblClick(Sender: TObject);
    procedure TablesGridKeyPress(Sender: TObject; var Key: Char);
    procedure GridDblClick(Sender: TObject);
    procedure AfterPost(DataSet: TDataset);
    procedure CloseItemClick(Sender: TObject);
    procedure FilterItemClick(Sender: TObject);
    procedure PopupSQLMenuClick(Sender: TObject);
    procedure PopupSQLMenuPopup(Sender: TObject);
    procedure SQLMemoChange(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure CancelQueryClick(Sender: TObject);
    procedure AfterOpen(DataSet: TDataset);
    procedure NavigateSQLClick(Sender: TObject);
    procedure FormStorageRestorePlacement(Sender: TObject);
    procedure FormStorageSavePlacement(Sender: TObject);
    procedure DataSource2StateChange(Sender: TObject);
    procedure RefIntListCalcFields(DataSet: TDataset);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure CloseTableItemClick(Sender: TObject);
    procedure rxDBGrid2CheckButton(Sender: TObject; ACol: Longint;
      Field: TField; var Enabled: Boolean);
    procedure rxDBGrid2TitleBtnClick(Sender: TObject; ACol: Longint;
      Field: TField);
    procedure rxDBGrid2GetBtnParams(Sender: TObject; Field: TField;
      AFont: TFont; var Background: TColor; var SortMarker: TSortMarker;
      IsDown: Boolean);
  private
    { Private declarations }
    FSQLHistoryIndex: Integer;
    FSQLHistory: TStrings;
    FQueryRunning: Boolean;
    FQueryStartTime: Longint;
    FRefIntListTYPE: TField; { for Delphi 16/32 compatibility }
{$IFDEF WIN32}
    FTrayIcon: TRxTrayIcon;
    FAbortQuery: Boolean;
{$ENDIF}
    function GetDatabaseName: string;
    function GetActiveDataSource: TDataSource;
    procedure SetDatabaseName(const Value: string);
    procedure CloseCurrent;
    procedure InternalOpenCurrent(const TabName: string);
    procedure UpdateFieldFormats(DataSet: TDataSet);
    procedure UpdateSQLHistory;
    procedure EnableSQLHistoryItems;
    procedure ExecSQL;
    procedure StartWatch;
    procedure StopWatch;
{$IFDEF WIN32}
    procedure QueryAborting(DataSet: TDataSet; var AbortQuery: Boolean);
{$ENDIF}
  public
    { Public declarations }
{$IFDEF WIN32}
    QueryDB: TDatabase;
{$ENDIF}
    function CheckStandard: Boolean;
    procedure UpdateSystemTables;
    procedure UpdateDataFieldFormats;
    procedure SetToCurrentTable;
    procedure PackCurrentTable;
    procedure CheckAndRepairParadoxTable(AllTables: Boolean);
    procedure ExportCurrentTable;
    procedure ImportToCurrentTable;
    procedure ReindexTable;
    function CurrentTable: TTable;
    function TransOperEnabled(Operation: TTransOperation): Boolean;
    procedure StartTransaction;
    procedure Commit;
    procedure Rollback;
    procedure RefreshData;
    property DatabaseName: string read GetDatabaseName write SetDatabaseName;
    property DataSource: TDataSource read GetActiveDataSource;
  end;

implementation

{$B-}
{$R *.DFM}

uses SysUtils, Clipbrd, DBConsts, TUtil, VCLUtils, ObjStr, Options,
  {$IFDEF WIN32} Bde, {$ELSE} DbiTypes, DbiProcs, {$ENDIF} FileUtil,
  EditStr, EditPict, ViewBlob, DbUtils, BdeUtils, Main, FiltDlg,
  DestTab, SrcTab, BdeInfo;

{ TMDIChild }

function TMDIChild.GetDatabaseName: string;
begin
  Result := TableList.DatabaseName;
end;

procedure TMDIChild.SetDatabaseName(const Value: string);
begin
  if Self.DatabaseName <> Value then begin
    TableList.Close;
    try
      TableList.DatabaseName := Value;
      TableList.SystemItems := SystemTables;
      Table1.DatabaseName := Value;
      Query1.DatabaseName := Value;
      FieldList1.DatabaseName := Value;
      IndexList1.DatabaseName := Value;
      RefIntList.DatabaseName := Value;
      TableList.Open;
      if Value <> '' then Caption := Format('Database: %s', [Value]);
    except
      Close;
      raise;
    end;
  end;
end;

procedure TMDIChild.RefreshData;
begin
  TableList.Close;
  try
    TableList.Open;
  except
    Close;
    raise;
  end;
end;

function TMDIChild.GetActiveDataSource: TDataSource;
begin
  Result := DataSource2;
end;

procedure TMDIChild.UpdateDataFieldFormats;
begin
  UpdateFieldFormats(Table1);
  UpdateFieldFormats(Query1);
  rxDBGrid2.Refresh;
  rxDBGrid3.Refresh;
end;

procedure TMDIChild.UpdateFieldFormats(DataSet: TDataSet);
var
  I: Integer;
begin
  for I := 0 to DataSet.FieldCount - 1 do begin
    case DataSet.Fields[I].DataType of
      ftFloat, ftCurrency, ftBCD:
        begin
          TNumericField(DataSet.Fields[I]).DisplayFormat := defFloatFormat;
          TNumericField(DataSet.Fields[I]).EditFormat := '#.##';
        end;
      ftDate: TDateTimeField(DataSet.Fields[I]).DisplayFormat := defDateFormat;
      ftTime: TDateTimeField(DataSet.Fields[I]).DisplayFormat := defTimeFormat;
      ftDateTime: TDateTimeField(DataSet.Fields[I]).DisplayFormat := defDateTimeFormat;
    end;
  end;
end;

procedure TMDIChild.UpdateSystemTables;
begin
  TableList.SystemItems := SystemTables;
end;

function TMDIChild.CurrentTable: TTable;
var
  Val: string;
begin
  if not TableList.Active then begin
    Result := nil;
    Exit;
  end;
  Val := TableListTABNAME.AsString;
  if Table1.Active then begin
    if Table1.TableName <> Val then SetToCurrentTable;
  end
  else begin
    Table1.TableName := Val;
  end;
  Result := Table1;
end;

function TMDIChild.CheckStandard: Boolean;
begin
  Result := False;
  if TableList.Database <> nil then
    Result := not TableList.Database.IsSQLBased;
end;

function TMDIChild.TransOperEnabled(Operation: TTransOperation): Boolean;
var
  InTransNow: Boolean;
begin
  Result := False;
  if (TableList.Database <> nil) and (TableList.Database.IsSQLBased) then
  begin
    InTransNow := TransActive(TableList.Database);
    case Operation of
      teStart: Result := not InTransNow;
      teCommit: Result := InTransNow;
      teRollback: Result := InTransNow;
    end;
  end;
end;

procedure TMDIChild.StartTransaction;
begin
  if TransOperEnabled(teStart) then begin
    TableList.Database.StartTransaction;
  end;
  TDBExplorerMainForm(Application.MainForm).UpdateMenus;
end;

procedure TMDIChild.Commit;
begin
  if TransOperEnabled(teCommit) then
  try
    if TransActive(TableList.Database) then
    try
      TableList.Database.Commit;
    except
      Rollback;
      raise;
    end;
    MessageDlg('Changes successfully commited to a database.',
      mtInformation, [mbOk], 0);
  finally
    TDBExplorerMainForm(Application.MainForm).UpdateMenus;
  end;
end;

procedure TMDIChild.Rollback;
begin
  try
    if TransActive(TableList.Database) then TableList.Database.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
    raise EDatabaseError.Create('Cannot perform this operation on a SQL database');
  KeepActive := Table1.Active;
  CloseCurrent;
  if not FQueryRunning then Query1.Close;
  try
    if AllTables then begin
      CheckTables(DatabaseName, crConfirmRepair);
      MessageDlg('Verification complete.', 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;

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('Table %s successfully created.', [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;
    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;
    end;
  end;
end;

procedure TMDIChild.InternalOpenCurrent(const TabName: string);
begin
  FieldList1.TableName := TabName;
  IndexList1.TableName := TabName;
  RefIntList.TableName := TabName;
  try
    if not Table1.Active then Table1.TableName := TabName;
    Table1.Open;
    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);
        finally
          InternalOpenCurrent(Val);
        end;
      end;
    end;
  finally
    DataSource.DataSet.EnableControls;
    StopWait;
  end;
end;

procedure TMDIChild.CloseCurrent;
begin