queryform.~pas

一个使用Delphi编写的ADO数据库链接查看器

unit QueryForm;
//在这个窗体中，实现用户的基本操作界面。这是一个单文档的窗体。
interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Grids, DBGrids, StdCtrls, ComCtrls, ExtCtrls, ActnList, Menus,
  ToolWin, ActnMan, ActnCtrls, Buttons, UnitADOModule, ChAdoConEd60, ADOInt,
  StdActns, ADOdb, ImgList;

type
  TFormMain = class(TForm)
    ActionList: TActionList;
    ActDock: TAction;
    PopupMenu: TPopupMenu;
    ActCanDrag1: TMenuItem;
    CoolBar1: TCoolBar;
    ActionToolBar1: TActionToolBar;
    Panel1: TPanel;
    ConnectionString: TLabeledEdit;
    SpeedButton1: TSpeedButton;
    ADOConnect: TAction;
    PanButtom: TPanel;
    Pages: TPageControl;
    DataPage: TTabSheet;
    DBGrid1: TDBGrid;
    InfoPage: TTabSheet;
    REInfo: TRichEdit;
    ExecCommand: TAction;
    QueryData: TAction;
    ActionManager: TActionManager;
    LoadCmd: TFileOpen;
    SaveCmd: TFileSaveAs;
    PanLeft: TPanel;
    TVDatabase: TTreeView;
    Splitter2: TSplitter;
    Splitter1: TSplitter;
    PanTop: TPanel;
    REText: TRichEdit;
    ActShowTV: TAction;
    ActShowCmd: TAction;
    ShowText1: TMenuItem;
    InfoText1: TMenuItem;
    ActRefresh: TAction;
    ImageList: TImageList;
    ActDisconn: TAction;
    procedure ActDockExecute(Sender: TObject);
    procedure ControlStartDock(Sender: TObject;
      var DragObject: TDragDockObject);
    procedure ControlEndDock(Sender, Target: TObject; X, Y: Integer);
    procedure ADOConnectExecute(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure ExecCommandExecute(Sender: TObject);
    procedure QueryDataExecute(Sender: TObject);
    procedure LoadCmdAccept(Sender: TObject);
    procedure SaveCmdAccept(Sender: TObject);
    procedure ActShowTVExecute(Sender: TObject);
    procedure ActShowCmdExecute(Sender: TObject);
    procedure TVDatabaseRefresh(Sender : TObject);
  private
    { Private declarations }
    function isEmpty(Container : TWinControl) : Boolean;
    procedure CanSite(Sender : TObject);
    procedure ActCanShowExecute(Sender: TObject); overload;
    procedure ActCanShowExecute(Sender: TTabSheet); overload;
    function IndexByName(ObjName : String; Level : Integer = -1): Integer;
    procedure TVTablesRefresh(ObjList : TStrings);
    procedure TVProceduresRefresh(ObjList : TStrings);
    procedure TVFieldsRefresh(TableName : String; ObjList : TStrings);
  public
    { Public declarations }
  end;

var
  FormMain: TFormMain;

const
  Database = 'Database';
  StoreProcedures = 'Store Procedures';
  Tables = 'Tables';
  Fields = 'Fields';

implementation

{$R *.dfm}

procedure TFormMain.ActCanShowExecute(Sender: TObject);
begin
  (Sender as TWinControl).Visible := ((Sender as TWinControl).ControlCount > 0);
end;

procedure TFormMain.ActCanShowExecute(Sender: TTabSheet);
begin
  Sender.TabVisible := (Sender.ControlCount > 0);
end;

procedure TFormMain.ActDockExecute(Sender: TObject);
begin
  if ActDock.Checked then
  begin
    REText.DragMode := dmAutomatic;
    REText.DragKind := dkDock;
    TVDatabase.DragMode := dmAutomatic;
    TVDatabase.DragKind := dkDock;
  end
  else
  begin
    REText.DragMode := dmManual;
    REText.DragKind := dkDrag;
    TVDatabase.DragMode := dmManual;
    TVDatabase.DragKind := dkDrag;
  end;
end;

//在控件开始拖动后，向控件显示所有的可入坞容器。
procedure TFormMain.ControlStartDock(Sender: TObject;
  var DragObject: TDragDockObject);
begin
  CanSite(Sender);
end;

//控件结束拖动，将空容器隐藏，并为可能有的新页面标注标题。
procedure TFormMain.ControlEndDock(Sender, Target: TObject; X, Y: Integer);
begin
  ActCanShowExecute(PanTop);
  ActCanShowExecute(PanLeft);
  (Sender as TControl).Align := alClient;

  if REText.Parent.ClassNameIs('TTabSheet') then
    (REText.Parent as TTabSheet).Caption := '文本/指令';
  if TVDatabase.Parent.ClassNameIs('TTabSheet') then
    (TVDatabase.Parent as TTabSheet).Caption := '数据库结构';
end;

//建立ADO联接，这段代码参考了Delphi的Demo，并对VCL的部分源码进行了改动，但不会影
//响已有的类库。
procedure TFormMain.ADOConnectExecute(Sender: TObject);
begin
  try
    DMADO.ADOConnection.Close;
    DMADO.ADOConnection.ConnectionString := ConnectionString.Text;
    if EditConnectionString(DMADO.ADOConnection) then
      ConnectionString.Text := DMADO.ADOConnection.ConnectionString;
    if DMADO.ADOConnection.ConnectionString = '' then exit;
    Screen.Cursor := crHourGlass;
    DMADO.ADOConnection.Open;
    if DMADO.ADOConnection.State = [stOpen]	then
      TVDatabaseRefresh(Sender);
  finally
    Screen.Cursor := crDefault;
  end;
end;

procedure TFormMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  DMADO.ADOConnection.Close;
end;

procedure TFormMain.ExecCommandExecute(Sender: TObject);
begin
  DMADO.ADOCommand.CommandText := REText.Lines.Text;
  DMADO.ADOCommand.Execute;
  Pages.ActivePage := InfoPage;
end;

//在同一次执行中不加区分地处理有无结果集的SQL。
procedure TFormMain.QueryDataExecute(Sender: TObject);
var
  EffRecs : Integer;
  ADORecSet : _RecordSet;
begin
  try
    Screen.Cursor := crHourGlass;
    DMADO.ADOCommand.CommandText := REText.Lines.Text;
    ADORecSet := DMADO.ADOCommand.Execute(EffRecs, null);
    if ADORecSet.State = 0 then
    begin
      REInfo.Lines.Text := '本次操作影响了 ' + IntToStr(EffRecs) + ' 行。';
      DMADO.ADODataSetMain.Close;
      Pages.ActivePage := InfoPage;
    end
    else
    begin
      if EffRecs = -1 then EffRecs := 0;
      REInfo.Lines.Text := '共返回了 ' + IntToStr(ADORecSet.RecordCount)+ ' 行。'
                         + '本次操作另外影响了 ' + IntToStr(EffRecs) + ' 行。';
      DMADO.ADODataSetMain.Recordset := ADORecSet._xClone;
      ADORecSet.Close;
      Pages.ActivePage := DataPage;
    end;
  finally
    Screen.Cursor := crDefault;
  end;
end;

procedure TFormMain.LoadCmdAccept(Sender: TObject);
begin
  REText.Lines.LoadFromFile(LoadCmd.Dialog.FileName);
end;

procedure TFormMain.SaveCmdAccept(Sender: TObject);
begin
  REText.Lines.SaveToFile(SaveCmd.Dialog.FileName);
end;

//使空容器可以停靠。
procedure TFormMain.CanSite(Sender : TObject);
var
  TopIsEmpty, LeftIsEmpty : Boolean;
begin
  TopIsEmpty := isEmpty(PanTop);
  LeftIsEmpty := isEmpty(PanLeft);

  PanTop.DockSite := TopIsEmpty;
  PanTop.Visible := TopIsEmpty;
  if TopIsEmpty then
    PanTop.ClientHeight := (Sender as TControl).Height;
  PanLeft.DockSite := LeftIsEmpty;
  PanLeft.Visible := LeftIsEmpty;
  if LeftIsEmpty then
    PanLeft.ClientWidth := (Sender as TControl).Width;
end;

//指定容器是否为空；
function TFormMain.isEmpty(Container: TWinControl): Boolean;
begin
  result := (Container.ControlCount = 0);
end;

procedure TFormMain.ActShowTVExecute(Sender: TObject);
begin
  TVDatabase.Visible := True;
  if TVDatabase.Parent.ClassNameIs('TTabSheet') then
    Pages.ActivePage := (TVDatabase.Parent as TTabSheet);
end;

procedure TFormMain.ActShowCmdExecute(Sender: TObject);
begin
  REText.Visible := True;
  if REText.Parent.ClassNameIs('TTabSheet') then
    Pages.ActivePage := (REText.Parent as TTabSheet);
end;

procedure TFormMain.TVDatabaseRefresh;
var
  i : Integer;
  ObjList, FieldList : TStringList;
begin
  if DMADO.ADOConnection.State = [stClosed] then exit;
  ObjList := TStringList.Create;
  FieldList := TStringList.Create;
  TVTablesRefresh(ObjList);
  for i := 0 to ObjList.Count - 1 do
  begin
    TVFieldsRefresh(ObjList.Strings[i], FieldList);
  end;
  TVProceduresRefresh(ObjList);
  FieldList.Free;
  ObjList.Free;
end;

function TFormMain.IndexByName(ObjName: String; Level : Integer = -1): Integer;
begin
  Result := 0 ;
  while Result < TVDatabase.Items.Count do
  begin
    if (TVDatabase.Items.Item[Result].Text = ObjName)
        and ((Level = -1) or (TVDatabase.Items.Item[Result].Level = Level)) then
      Break
    else
      Inc(Result);
  end;
  if Result = TVDatabase.Items.Count then
    Result := -1;
end;

procedure TFormMain.TVFieldsRefresh(TableName: String; ObjList : TStrings);
var
  Index, i : Integer;
begin
  try
    Screen.Cursor := crHourGlass;
    ObjList.Clear;
    DMADO.ADOConnection.GetFieldNames(TableName, ObjList);
    Index := IndexByName(TableName, 2);
    TVDatabase.Items.Item[Index].DeleteChildren;
    for i := 0 to ObjList.Count - 1 do
    begin
      with TVDatabase.Items.AddChild(TVDatabase.Items.Item[Index],
                                      ObjList.Strings[i]) do
      begin
        ImageIndex := 1;
        SelectedIndex := 1;
      end;
    end;
  finally
    Screen.Cursor := crDefault;
  end;
end;

procedure TFormMain.TVProceduresRefresh(ObjList : TStrings);
var
  Index, i : Integer;
begin
  try
    Screen.Cursor := crHourGlass;
    ObjList.Clear;
    DMADO.ADOConnection.GetProcedureNames(ObjList);
    Index := IndexByName(StoreProcedures);
    TVDatabase.Items.Item[Index].DeleteChildren;
    for i := 0 to ObjList.Count - 1 do
    begin
      with TVDatabase.Items.AddChild(TVDatabase.Items.Item[Index],
                                     ObjList.Strings[i]) do
      begin
        ImageIndex := 15;
        SelectedIndex := 15
      end;
    end;
  finally
    Screen.Cursor := crDefault;
  end;
end;

procedure TFormMain.TVTablesRefresh(ObjList : TStrings);
var
  Index, i : Integer;
begin
  try
    Screen.Cursor := crHourGlass;
    ObjList.Clear;
    DMADO.ADOConnection.GetTableNames(ObjList);
    Index := IndexByName(Tables, 1);
    TVDatabase.Items.Item[Index].DeleteChildren;
    for i := 0 to ObjList.Count - 1 do
    begin
      with TVDatabase.Items.AddChild(TVDatabase.Items.Item[Index],
                                      ObjList.Strings[i]) do
      begin
        ImageIndex := 2;
        SelectedIndex := 2;
      end;
    end;
  finally
    Screen.Cursor := crDefault;
  end;
end;

end.