ccreatedb.pas

控件作用: 自动创建SQL数据库(可以同时间创建多个数据库) 控件用法: 1:添加数据库(可以添加多个数据库)选择相应的数据库. 2:添加SQL文件(创建数据表,视图,过程.可从SQL文件中

unit cCreateDB;

interface

uses
  Windows, Messages, SysUtils, Classes, ADODB, Controls, ComCtrls, Dialogs,
  StdCtrls, Forms, Graphics;

const
  cFinishMsg = WM_USER + 2003 + 8 * 30 + 13 + 1;
  cErrorMsg = WM_USER + 2003 + 8 * 30 + 13 + 2;
  cCancelMsg = WM_USER + 2003 + 8 * 30 + 13 + 3;

type
  TcState = (cCanceling, cCanceled, cErrored, cFinish, cDoing);

  TcCreateDB = class(TCustomControl)
  private
    { Private declarations }
  protected
    { Protected declarations }
    FADOCN: TADOConnection;
    FHFile: textfile;
    FScriptFilename: TFilename;
    FScripts: TStrings;
    FCancel: Boolean;
    FProgressBar: TProgressBar;
    FReplaceExists: Boolean;
    FState: TcState;
    FOnFinish: TNotifyEvent;
    FOnError: TNotifyEvent;
    FOnCancel: TNotifyEvent;
    procedure setScriptFilename(filename: TFilename);
    procedure setFScripts(Value: TStrings);
    procedure setFADOCN(Value: TADOConnection);
    procedure FinishMsg(var aMsg: TMessage); message cFinishMsg;
    procedure ErrorMsg(var aMsg: TMessage); message cErrorMsg;
    procedure CancelMsg(var aMsg: TMessage); message cCancelMsg;
    procedure Paint; override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Execute; virtual;
    procedure Cancel; virtual;
  published
    { Published declarations }
    property ScriptFilename: TFilename read FScriptFilename write setScriptFilename;
    property ProgressBar: TProgressBar read FProgressBar write FProgressBar;
    property ReplaceExists: Boolean read FReplaceExists write FReplaceExists;
    property Scripts: TStrings read FScripts write setFScripts;
    property Connection: TADOConnection read FADOCN write setFADOCN;
    property OnFinish: TNotifyEvent read FOnFinish write FOnFinish;
    property OnError: TNotifyEvent read FOnError write FOnError;
    property OnCancel: TNotifyEvent read FOnCancel write FOnCancel;
  end;

  TcCreateDBThread = Class(TThread)
  protected
    FParent: TcCreateDB;
    FADOQ: TADOQuery;
    procedure Execute; override;
    procedure Submit;
  public
    constructor Create(Parent: TcCreateDB);
    destructor Destroy; override;
  end;

  RecDatabase = record
    Name: String;
    StrucDef: TStrings;
    SuspendData: TStrings;
  end;
  TArrDatabases = array of RecDatabase;

  TcDatabase = Class(TCollectionItem)
  private
    FDBName: String;
    FStrucDef: TStrings;
    FSuspendData: TStrings;
    function getStrucDef: TStrings;
    procedure setStrucDef(const Value: TStrings);
    function getDBName: String;
    procedure setDBName(const Value: String);
    function getSuspendData: TStrings;
    procedure setSuspendData(const Value: TStrings);
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
  published
    property DBName: String read getDBName write setDBName;
    property StrucDef: TStrings read getStrucDef write setStrucDef;
    property SuspendData: TStrings read getSuspendData write setSuspendData;
  end;

  TcDatabases = Class(TCollection)
  private
    function GetItem(Index: Integer): TcDatabase;
    procedure SetItem(Index: Integer; const Value: TcDatabase);
  public
    function Add: TcDatabase;
    procedure Assign(Source: TPersistent); override;
    property Items[Index: Integer]: TcDatabase read GetItem write SetItem;
  end;

  TcCreateDBV2 = Class(TCustomControl)
  private
    FADOCN: TADOConnection;
    function getDatabases: TcDatabases;
    procedure setDatabases(const Value: TcDatabases);
    function getBeforeDBCommand: TStrings;
    procedure setBeforeDBCommand(const Value: TStrings);
    function getAfterDBCommand: TStrings;
    procedure setAfterDBCommand(const Value: TStrings);
  protected
    FCancel: Boolean;
    FProgressBar: TProgressBar;
    FReplaceExists: Boolean;
    FState: TcState;
    FDatabases: TcDatabases;
    FBeforeDBCommand: TStrings;
    FAfterDBCommand: TStrings;
    FOnFinish: TNotifyEvent;
    FOnError: TNotifyEvent;
    FOnCancel: TNotifyEvent;
    procedure setFADOCN(Value: TADOConnection);
    procedure FinishMsg(var aMsg: TMessage); message cFinishMsg;
    procedure ErrorMsg(var aMsg: TMessage); message cErrorMsg;
    procedure CancelMsg(var aMsg: TMessage); message cCancelMsg;
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Execute; virtual;
    procedure Cancel; virtual;
  published
    property ProgressBar: TProgressBar read FProgressBar write FProgressBar;
    property ReplaceExists: Boolean read FReplaceExists write FReplaceExists;
    property Connection: TADOConnection read FADOCN write setFADOCN;
    property Databases: TcDatabases read getDatabases write setDatabases;
    property BeforeDBCommand: TStrings read getBeforeDBCommand write setBeforeDBCommand;
    property AfterDBCommand: TStrings read getAfterDBCommand write setAfterDBCommand;
    property OnFinish: TNotifyEvent read FOnFinish write FOnFinish;
    property OnError: TNotifyEvent read FOnError write FOnError;
    property OnCancel: TNotifyEvent read FOnCancel write FOnCancel;
    property Caption;
  end;

  TcCreateDBV2Thread = Class(TThread)
  protected
    FParent: TcCreateDBV2;
    FADOQ: TADOQuery;
    procedure Execute; override;
    procedure Submit;
    procedure StepIt;
  public
    constructor Create(var Parent: TcCreateDBV2);
    destructor Destroy; override;
  end;

implementation

{ TcCreateDB }

procedure TcCreateDB.Cancel;
begin
  if FCancel then
  else begin
    FCancel := true;
    FState := cCanceling;
    While FState <> cCanceled do
      Application.ProcessMessages;
  end;
end;

procedure TcCreateDB.CancelMsg(var aMsg: TMessage);
begin
  if Assigned(FOnCancel) then
    FOnCancel(Self);
  FState := cCanceled;
  inherited;
end;

constructor TcCreateDB.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCancel := true;
  FScripts := TStringList.Create;
  ControlStyle := [csReplicatable];
  Canvas.Pen.Mode := pmMerge;
end;

destructor TcCreateDB.Destroy;
begin
  FScripts.Free;
  inherited;
end;

procedure TcCreateDB.ErrorMsg(var aMsg: TMessage);
begin
  if Assigned(FOnError) then
    FOnError(Self);
  FCancel := true;
  inherited;
end;

procedure TcCreateDB.Execute;
begin
  if (FScripts.Count < 1) or (Not Assigned(FADOCN)) then
    Raise Exception.Create('未指定执行脚本！');
  FCancel := false;
  TcCreateDBThread.Create(Self);
end;

procedure TcCreateDB.FinishMsg(var aMsg: TMessage);
begin
  if Assigned(FOnFinish) then
    FOnFinish(Self);
  FCancel := true;
  inherited;
end;

procedure TcCreateDB.Paint;
var
  r: TRect;
begin
  inherited;
  r := ClientRect;
  if csDesigning in ComponentState then
    DrawText(Self.Canvas.Handle, PChar(Name), Length(Name), r, 0)
  else begin
    DrawText(Canvas.Handle, PChar(Name), 0, r, 0);
  end;
end;

procedure TcCreateDB.setFADOCN(Value: TADOConnection);
begin
  //FADOCN.Assign(Value);
  FADOCN := Value;
end;

procedure TcCreateDB.setFScripts(Value: TStrings);
begin
  FScripts.Assign(Value);
end;

procedure TcCreateDB.setScriptFilename(filename: TFilename);
var
  sTmp: String;
begin
  if Trim(filename) = '' then
    FScriptFilename := ''
  else if FileExists(filename) then
  begin
    FScriptFilename := filename;
    FScripts.Clear;
    AssignFile(FHFile, FScriptFilename);
    Reset(FHFile);
    While Not Eof(FHFile) do
    begin
      Readln(FHFile, sTmp);
      FScripts.Add(sTmp)
    end;
    CloseFile(FHFile);
  end
  else
    //Raise Exception.Create('指定的文件不存在‘' + filename + '’');
    FScriptFilename := '';
end;

{ TcCreateDBThread }

constructor TcCreateDBThread.Create(Parent: TcCreateDB);
begin
  inherited Create(true);
  FParent := Parent;
  FADOQ := TADOQuery.Create(Nil);
  FADOQ.Connection := FParent.FADOCN;
  FADOQ.Parameters.AddParameter;
  FADOQ.Parameters.Items[0].Name := 'ReplaceExists';
  if Assigned(FParent.ProgressBar) then
  begin
    FParent.ProgressBar.Step := 1;
    FParent.ProgressBar.Max := FParent.FScripts.Count;
    FParent.ProgressBar.Position := 0;
  end;
  FreeOnTerminate := true;
  Resume;
end;

destructor TcCreateDBThread.Destroy;
begin
  if FADOQ.Active then FADOQ.Close;
  FADOQ.Free;
  if Assigned(FParent.FProgressBar) then
  begin
    FParent.FProgressBar.Position := 0;
    FParent.FProgressBar.Max := 0; 
  end;
  inherited;
end;

procedure TcCreateDBThread.Execute;
var
  i: Integer;
begin
  i := 0;
  While (i < FParent.FScripts.Count) and (Not Terminated) do
  begin
    if FParent.FCancel then
    begin
      PostMessage(FParent.Handle, cCancelMsg, 0, 0);
      Exit;
    end;
    if Assigned(FParent.FProgressBar) then
      FParent.FProgressBar.StepIt;
    if UpperCase(Trim(FParent.FScripts[i])) = 'GO' then
      Submit
    else if Trim(FParent.FScripts[i]) <> '' then
      FADOQ.SQL.Add(Trim(FParent.FScripts[i]));
    Inc(i);
  end;
  if Not Terminated then
  begin
    Submit;
    PostMessage(FParent.Handle, cFinishMsg, 0, 0);
  end;
end;

procedure TcCreateDBThread.Submit;
var
  f: textfile;
  i: Integer;
begin
  if FADOQ.SQL.Count < 1 then Exit;
  try
    if FParent.FReplaceExists then
      FADOQ.Parameters.ParamByName('ReplaceExists').Value := 1
    else
      FADOQ.Parameters.ParamByName('ReplaceExists').Value := 0;
  except

  end;
  try
    FADOQ.ExecSQL;
    FADOQ.Close;
    FADOQ.SQL.Clear;
  except
    AssignFile(f, ExtractFilePath(Application.ExeName) + 'error.log');
    reWrite(f);