Analitcs

Pesquisar no conteúdo do blog.atlabs.com.br

quarta-feira, 27 de junho de 2012

DELPHI/FIREBIRD - Criação de banco (Firebird/Interbase) em RunTime (tempo de execução) e Execução de script de criação.

Reações: 


// ATLabs 27-06-2012
// Unit1.pas inicio

Unit Unit1;

interface

uses

  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, DB, IBDatabase, IBCustomDataSet, IBQuery, DBXpress,
  SqlExpr, Gauges;

type

  TForm1 = class(TForm)
    IBDatabase1: TIBDatabase;
    Button1: TButton;
    IBTransaction1: TIBTransaction;
    IBQuery1: TIBQuery;
    OpenDialog1: TOpenDialog;
    Gauge1: TGauge;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    procedure ExecutaScript(DBNAME, sArquivo: String);
    procedure CommitWork;
    Function ExecutaSQL(S : String; Var sError : String) : Boolean;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

Const
    fProcedures = 'STORED PROCEDURES';
    fViews      = 'VIEWS';
    fTables     = 'TABLES';
    fInsert     = 'INSERT INTO ';
    fDelete     = 'DELETE FROM ';
    fSetGen     = 'SET GENERATOR ';
    fCommit     = 'COMMIT WORK;';

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
const
  DataBaseName = 'C:\TMP\BASE.GDB';
var
  i : Integer;  
begin
  IBDatabase1.DatabaseName := DataBaseName;
  IBDatabase1.LoginPrompt := false;
  if not FileExists(DataBaseName) then
  begin
    IBDatabase1.Params.Text :=
      ' USER ''SYSDBA'' PASSWORD ''masterkey'' ' +
      ' PAGE_SIZE 8192 ' +
      ' DEFAULT CHARACTER SET NONE COLLATION NONE ';
    IBDatabase1.CreateDatabase;
    ShowMessage('Banco de dados ' + DataBaseName + ' criado com sucesso!');
  end;
  IBDatabase1.Close;
  IBDatabase1.Params.Clear;
  IBDatabase1.Params.Add('user_name=sysdba');
  IBDatabase1.Params.Add('password=masterkey');

  IBDatabase1.Open;
  if OpenDialog1.Execute then
  begin
    Gauge1.Visible := True;
    try
    Self.ExecutaScript(DataBaseName, OpenDialog1.FileName);
    finally
      Gauge1.Visible := False;
    end;
  end;
  IBDatabase1.Close;
end;

procedure TForm1.CommitWork;
var
  ibqCommit : TIBQuery;
begin
  Try
    ibqCommit             := TIBQuery.Create(Nil);
    ibqCommit.Database    := IBDatabase1;
    ibqCommit.Transaction := IBDatabase1.DefaultTransaction;
    ibqCommit.Close;
    ibqCommit.SQL.Text := 'Commit Work';
    ibqCommit.ExecSQL;
  Finally
    FreeAndNil(ibqCommit);
  End;
end;


procedure TForm1.ExecutaScript(DBNAME, sArquivo: String);
var
  Strs, sSQL : TStringList;
  SQL, sItem, scTipo, sNProc, cEnd, sMSG, sError : String;
  I, Itens, ItensProc, ItensNProc,
  ErrorCode : Integer;
  SQLConnection : TSQLConnection;
Const

  cView0  = 'CREATE VIEW ';
  cView1  = 'CREATE OR ALTER VIEW ';
  cSP0    = 'CREATE PROCEDURE ';
  cSP1    = 'ALTER PROCEDURE ';
  cSP2    = 'CREATE OR ALTER PROCEDURE ';

  cCreate       = 'CREATE ';
  cCreateErr0   = 'CREATE DATABASE ';

  cAlter        = 'ALTER ';
  cInsert       = 'INSERT ';
  cDelete       = 'DELETE ';
  cDescrib      = 'DESCRIBE ';
  cDeclareExt   = 'DECLARE EXTERNAL ';
  cSet          = 'SET ';
  cSetErr0      = 'SET SQL ';
  cSetErr1      = 'SET NAMES ';
  cSetErr2      = 'SET TERM ';
  cCommit       = 'COMMIT ';
  cEndP         = '^';
  cEndAll       = ';';

  procedure LimpaVars;
  begin
    sSQL.Clear;
    sSQL.text := '';
    SQL := '';
    scTipo := '';
    sItem := '';
  end;

  function ValidaItem(SQL : String) : Boolean;
  begin
    Result := False;
    if (
       ((POS(cCreate, UpperCase(SQL)) = 1)
       and (POS(cCreateErr0, UpperCase(SQL)) = 0)
       )
    or (POS(cView0, UpperCase(SQL)) = 1)
    or (POS(cView1, UpperCase(SQL)) = 1)
    or (POS(cSP0, UpperCase(SQL)) = 1)
    or (POS(cSP1, UpperCase(SQL)) = 1)
    or (POS(cSP2, UpperCase(SQL)) = 1)
    or (POS(cAlter, UpperCase(SQL)) = 1)
    or (POS(cInsert, UpperCase(SQL)) = 1)
    or (POS(cDelete, UpperCase(SQL)) = 1)
    or (POS(cDescrib, UpperCase(SQL)) = 1)
    or (POS(cDeclareExt, UpperCase(SQL)) = 1)
    or ((POS(cSet, UpperCase(SQL)) = 1)
         and (POS(cSetErr0, UpperCase(SQL)) = 0)
         and (POS(cSetErr1, UpperCase(SQL)) = 0)
       )
    or (POS(cCommit, UpperCase(SQL)) = 1)) then
    Result := True;
  end;

  Procedure SetItem(SQL : String);
  begin
    scTipo := '';
    if ValidaItem(SQL) then
    begin
      if (POS(cCreate, UpperCase(SQL)) = 1) then
        scTipo := cCreate;
      if (POS(cView0, UpperCase(SQL)) = 1) then
        scTipo := cView0;
      if (POS(cView1, UpperCase(SQL)) = 1) then
        scTipo := cView1;
      if (POS(cSP0, UpperCase(SQL)) = 1) then
        scTipo := cSP0;
      if (POS(cSP1, UpperCase(SQL)) = 1) then
        scTipo := cSP1;
      if (POS(cSP2, UpperCase(SQL)) = 1) then
        scTipo := cSP2;

      if (POS(cAlter, UpperCase(SQL)) = 1) then
        scTipo := cAlter;

      if (POS(cInsert, UpperCase(SQL)) = 1) then
        scTipo := cInsert;
      if (POS(cDelete, UpperCase(SQL)) = 1) then
        scTipo := cDelete;
      if (POS(cDescrib, UpperCase(SQL)) = 1) then
        scTipo := cDescrib;
      if (POS(cDeclareExt, UpperCase(SQL)) = 1) then
        scTipo := cDeclareExt;
      if (POS(cSet, UpperCase(SQL)) = 1) then
        scTipo := cSet;
      if (POS(cCommit, UpperCase(SQL)) = 1) then
        scTipo := cCommit;
    end;
  end;

  procedure SetValuecEnd(SQL : String);
  begin
    if ValidaItem(SQL) then
    begin
      cEnd := cEndAll;
      if (POS(cSP0, UpperCase(SQL)) = 1)
      or (POS(cSP1, UpperCase(SQL)) = 1)
      or (POS(cSP2, UpperCase(SQL)) = 1) then
      cEnd := cEndP;
    end;  
  end;

  Function SQLValido (SQL : TStringList) : Boolean;
  begin
    Result := False;
    if (POS(UpperCase(scTipo), UpperCase(SQL.Strings[0])) = 1) then
      Result := True
    Else
      LimpaVars;
  end;
begin

  try

    Strs := TStringList.Create;
    SQLConnection := TSQLConnection.Create(Nil);
    SQLConnection.ConnectionName := 'IBLocal';
    SQLConnection.DriverName     := 'Interbase';
    SQLConnection.GetDriverFunc  := 'getSQLDriverINTERBASE';
    SQLConnection.LibraryName    := 'dbexpint.dll';
    SQLConnection.Params.Text :=
      'BlobSize=-1' + #13#10 +
      'CommitRetain=False' + #13#10 +
      'Database=' + DBNAME + #13#10 +
      'DriverName=Interbase' + #13#10 +
      'ErrorResourceFile=' + #13#10 +
      'LocaleCode=0000' + #13#10 +
      'Password=masterkey' + #13#10 +
      'RoleName=RoleName' + #13#10 +
      'ServerCharSet=' + #13#10 +
      'SQLDialect=3' + #13#10 +
      'Interbase TransIsolation=ReadCommited' + #13#10 +
      'User_Name=sysdba' + #13#10 +
      'WaitOnLocks=True';
    SQLConnection.VendorLib := 'GDS32.DLL';
    SQLConnection.Open;

   if FileExists(sArquivo) then
    begin
      try
      sSQL := TStringList.Create;
      Strs.LoadFromFile(sArquivo);
      Gauge1.MinValue := 0;
      Gauge1.MaxValue := Strs.Count;

      I := 0;
      Itens := 0;
      ItensProc := 0;
      ItensNProc := 0;
      LimpaVars;

      while I <= Strs.Count - 1 do
      begin
        if (trim(StringReplace(Strs.Strings[i], #$D#$A, '', [rfReplaceAll, rfIgnoreCase])) = '')  and (sSQL.Count = 0) then
        begin
          Inc(I);
          Continue;
        end;


        if (sSQL.Count > 0)
        and (SQLValido(sSQL))
        and (POS(cEnd, sSQL.text) > 0)
        and (StringReplace(sSQL.text, #$D#$A, '', [rfReplaceAll, rfIgnoreCase]) <> '')
        and (ValidaItem(sSQL.Strings[0]))
        then
        begin
          Sleep(1);
          Application.ProcessMessages;
          SQL := sSQL.text;
            if cEnd = cEndP then
            begin
              Delete(SQL, Pos(cEnd,sSQL.text), 1);
              sSQL.text := SQL;
              try

              ErrorCode := SQLConnection.ExecuteDirect(sSQL.text);
              SQLConnection.ExecuteDirect('COMMIT WORK');
              except
                on e: Exception do
                begin
                  if POS(UpperCase('ALREADY EXISTS'), UpperCase(E.Message)) = 0 then
                  ShowMessage('Erro: ' + E.Message);
                  end;
              end;
              if ErrorCode <> 0 then
              begin
                sNProc := sNProc + ' ' + sItem;
                Inc(ItensNProc);
              end
              else
              Inc(ItensProc);
            end;

          if (cEnd = cEndAll) and (POS(cEndAll, sSQL.text) > 0) then
          begin
            Delete(SQL, Pos(cEnd,sSQL.text), 1);
            sSQL.text := SQL;

            if Self.ExecutaSQL(sSQL.text, sError) then
            begin
              Inc(ItensProc);
              Self.CommitWork;
            end
            else
            begin
              if POS(UpperCase('ALREADY EXISTS'), UpperCase(sError)) = 0 then
              begin
                sNProc := sNProc + ' ' + sItem;
                Inc(ItensNProc);
              end;
            end;
          end;

          LimpaVars;
          inc(Itens);
        end;


        if (trim(Strs.Strings[i]) <> '') then
        begin
          if (scTipo = '') then
            LimpaVars;

          SQL := Strs.Strings[i];

          if ValidaItem(SQL) then
          begin
            SetValuecEnd(SQL);
            if (POS(cView0, UpperCase(SQL)) > 0) then
            begin
              SQL := StringReplace(SQL, cView0, cView1, [rfReplaceAll, rfIgnoreCase]);
              scTipo := cView1;
            end;

            if (POS(cSP1, UpperCase(SQL)) > 0) then
            begin
              SQL := StringReplace(SQL, cSP1, cSP2, [rfReplaceAll, rfIgnoreCase]);
              scTipo := cSP2;
            end;

            SetItem(SQL);

            if  Pos('(', SQL) > 0 then
            begin
              sItem := Copy(SQL, POS(scTipo, UpperCase(SQL)) + Length(scTipo), Pos('(', SQL) - (POS(scTipo, UpperCase(SQL)) + Length(scTipo)));
              if  Pos(' ', sItem) > 0 then
              sItem := Copy(sItem, POS(' ', UpperCase(sItem)), Length(sItem));
            end
            else
              if (POS(cEnd, SQL) > 0) then
                sItem := SQL;
          end;
          Self.Caption := sItem;
          sSQL.Add(SQL);
        end;

        Inc(i);
        Gauge1.Progress := i;
      end;

      finally
        Gauge1.Progress := Strs.Count;
        FreeAndNil(sSQL);
        SQLConnection.Close;
        FreeAndNil(SQLConnection);
        Self.CommitWork;
        sMSG := 'Resumo Arquivo : ' + ExtractFileName(sArquivo) + #$D#$A +
                'Linhas: ' + inttostr(I) + #$D#$A +
                'Qtd. Itens: ' + inttostr(Itens) + #$D#$A +
                'Qtd. Itens Processados: ' + inttostr(ItensProc) + #$D#$A +
                'Qtd. Itens Não Processados: ' + inttostr(ItensNProc) + #$D#$A +
                TrimLeft(sNProc);

       ShowMessage(sMSG);
      end;

   end
    else
    begin
      ShowMessage('O arquivo: "' + sArquivo + '" não foi localizado. Cancelado.');
    end;
  finally
    FreeAndNil(Strs);
  end;
end;

function TForm1.ExecutaSQL(S : String; Var sError : String): Boolean;
var
  ibqExecSql : TIBQuery;
begin

  Try
    Result                 := False;
    ibqExecSql             := TIBQuery.Create(Nil);
    ibqExecSql.Database    := IBDatabase1;
    ibqExecSql.Transaction := IBDatabase1.DefaultTransaction;

    ibqExecSql.Close;
    ibqExecSql.SQL.Text := S;
    try
      ibqExecSql.ExecSQL;
      Result := True;
      sError := '';
    Except
      on E: Exception do
      begin
        Result := False;
        sError := E.Message;
      end;
    end;
  Finally
    FreeAndNil(ibqExecSql);
  End;
end;
end.
// Unit1.pas Fim


// Unit1.dfm Inicio

object Form1: TForm1
  Left = 175
  Top = 117
  Width = 169
  Height = 121
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object Gauge1: TGauge
    Left = 0
    Top = 73
    Width = 161
    Height = 14
    Align = alBottom
    Progress = 0
    Visible = False
  end
  object Button1: TButton
    Left = 43
    Top = 31
    Width = 75
    Height = 25
    Caption = 'Cria Base'
    TabOrder = 0
    OnClick = Button1Click
  end
  object IBDatabase1: TIBDatabase
    DatabaseName = 'C:\TMP\BASE.GDB'
    Params.Strings = (
      'user_name=sysdba'
      'password=masterkey')
    LoginPrompt = False
    DefaultTransaction = IBTransaction1
    IdleTimer = 0
    SQLDialect = 3
    TraceFlags = []
    Left = 27
    Top = 15
  end
  object IBTransaction1: TIBTransaction
    Active = False
    AutoStopAction = saNone
    Left = 27
    Top = 45
  end
  object IBQuery1: TIBQuery
    Database = IBDatabase1
    Transaction = IBTransaction1
    BufferChunks = 1000
    CachedUpdates = False
    Left = 75
    Top = 6
  end
  object OpenDialog1: TOpenDialog
    Filter = 'Arquivos *.sql|*.sql'
    Left = 114
    Top = 6
  end
end
// Unit1.dfm Fim

Nenhum comentário:

Postar um comentário

Observação: somente um membro deste blog pode postar um comentário.

Max Gehringer