Tool ZeosDB for Firebird and MySQL
lazarus / 16-Databases

----------------------------------------------------------------------
jaky2551 · 2018-02-18 03:34

I have an active tool for Firebird and MySQL which is run on ZeosDB.
Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i unit
DataUtils; {$mode objfpc}{$H+} // {$DEFINE DEBUGQUERY} interface uses 
Classes, SysUtils, FileUtil, Forms, Graphics, StdCtrls, ExtCtrls, DB, 
ZConnection, ZDataSet, ZStream, Dialogs; type  TDataType = (tdtEmbed,
tdtFirebird, tdtWinMySQL, tdtLXMySQL);  TSearchOrder = (tsoBefore,
tsoAfter, tsoAny);   TOnConnect = procedure(Sender: TObject;
Connected: Boolean) of object;   TConfig = record    HostName:
string[50];    UserName: string[40];    Password: string[40];   
Database: string[150];    Protocol: string[40];    Port: Word;   
DataType: TDataType;  end;   TDataUtil = class(TObject)  private   
FConnect: TZConnection;    FQuery: TZQuery;    FConfig: TConfig;   
FPath: string;//    FLibrary: string;    FBackupCompress: Boolean;   
FProgress: Boolean;     FOnConnect: TOnConnect;    FOnBackup:
TNotifyEvent;    FOnRestore: TNotifyEvent;     function GetHostName:
string;    function GetUserName: string;    function GetPassword:
string;    function GetPort: Word;    function GetDatabase: string;  
function GetDataType: TDataType;    procedure SetHostName(aHost:
string);    procedure SetUserName(aUser: string);    procedure
SetPassword(aPass: string);    procedure SetDatabase(aData: string); 
 procedure SetDataType(aData: TDataType);     procedure SetPath(aPath:
string);  protected    procedure PrepareConnect;  public   
constructor Create;    destructor Destroy; override;     function
ConnectDB: Boolean;    procedure DisconnectDB;    function Connected:
Boolean;     function HasDatabase(aDB: string): Boolean;    procedure
DatabaseList(DBList: TStringList);    procedure CreateDatabase(aDB:
string);    procedure DeleteDatabase(aDB: string);    function
OpenDatabase(aDB, aTB: string; Created: Boolean = True): Boolean;    
function HasTable(aTB: string): Boolean;    procedure
TableList(TBList: TStringList);    procedure CreateTable(TBList:
TStringList);    procedure DeleteTable(aTB: string);     function
HasField(aTB, aFD: string): Boolean;    procedure InsertField(aTB,
aFD, aTY, After: string);    procedure DeleteField(aTB, aFD: string); 
  function FieldIsType(aTB, aFD: string): TFieldType;     procedure
SetAutoInc(aTB: string; Def: Integer = 0);    function GetAutoInc(aTB:
string): Integer;    function NextAutoInc(aTB: string): Integer;   
function GetCodePage(aTB: string): string;     procedure
Backup2File(Filename: string);    procedure Restore4File(Filename:
string);    procedure LoadConfig(aFile: string);    procedure
SaveConfig(aFile: string);    function GetDBEmbed(aDB: string):
string;    function IsFirebird: Boolean;     procedure
LoadFromStream(aQuery: TZQuery; aFD: string; aMemo: TMemo);   
procedure LoadFromBlob(aQuery: TZQuery; aFD: string; aImg: TImage);  
procedure SaveToBlob(aQuery: TZQuery; aFD: string; aStream:
TStream);     procedure QueryExecSQL(aSQL: string);    procedure
QuerySQL(var rField: string; var rValue: string; const aField, aValue:
string); overload;    procedure QuerySQL(var rField: string; const
aField, aValue: string); overload;    procedure OpenQuery(aQuery:
TZQuery; aSQL: string = ''; aID: Integer = -1);    procedure
Delete4ID(aQuery: TZQuery; aTB: string; aID: Integer);    procedure
Search(aQuery: TZQuery; FromTable, InField, ByText: string;          
         tso: TSearchOrder = tsoBefore);    function
CanEditOrDelete(aQuery: TZQuery): Boolean;  published    property
Connection: TZConnection read FConnect;    property Query: TZQuery
read FQuery;    property Progress: Boolean read FProgress write
FProgress;     property HostName: string read GetHostName write
SetHostName;    property UserName: string read GetUserName write
SetUserName;    property Password: string read GetPassword write
SetPassword;    property Database: string read GetDatabase write
SetDatabase;    property Port: Word read GetPort;    property
DataType: TDataType read GetDataType write SetDataType default
tdtEmbed;     property Path: string read FPath write SetPath;   
property BackupCompress: Boolean read FBackupCompress write
FBackupCompress default False;     property OnConnect: TOnConnect read
FOnConnect write FOnConnect;    property OnBackup: TNotifyEvent read
FOnBackup write FOnBackup;    property OnRestore: TNotifyEvent read
FOnRestore write FOnRestore;  end; implementation uses 
ProUnt; function AddComma(aText: string): string;begin  Result :=
Trim(aText);  if Result <> '' then    Result := Result + ',
';end; function GetToken(var ss: string; dl: Char): string;begin  if
Pos(dl, ss) <> 0 then  begin    Result := Copy(ss, 1, Pos(dl, ss) -
1);    Delete(ss, 1, Pos(dl, ss));  end  else  begin    Result := ss; 
  ss := '';  end;end; function MySQLField(fd: string): string;var  qr:
string;begin  qr := UpperCase(Copy(fd, 1, 3));  if (qr = 'VAR') or (qr
= 'CHA') then    Result := fd // + ' CHARACTER SET utf8 COLLATE
utf8_bin'  else if qr = 'DAT' then    Result := 'DATETIME DEFAULT
''0000-00-00 00:00:00'''  else if qr = 'DEC' then    Result :=
'DECIMAL(10,2)'  else if qr = 'INT' then    Result := 'INT(11)'  else
if qr = 'DOU' then    Result := 'DOUBLE(10,2)'  else if qr = 'BLO'
then    Result := 'MEDIUMBLOB'  else    Result := fd;end;

----------------------------------------------------------------------
jaky2551 · 2018-02-18 03:36

Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i constructor
TDataUtil.Create;begin  inherited;  FConnect :=
TZConnection.Create(nil);   FQuery := TZQuery.Create(nil); 
FQuery.Connection := FConnect;   Path :=
ExtractFilePath(Application.ExeName);  DataType := tdtEmbed; 
FConfig.Database := '';   FProgress := False;   FBackupCompress :=
False;end; destructor TDataUtil.Destroy;begin  if FQuery.Active then 
 FQuery.Close;  FreeAndNil(FQuery);   if FConnect.Connected then   
FConnect.Disconnect;  FreeAndNil(FConnect);   inherited;end; procedure
TDataUtil.PrepareConnect;begin  if FConnect.Connected then   
FConnect.Disconnect;  FConnect.User := UserName;  FConnect.Password :=
Password;  FConnect.HostName := HostName;  FConnect.Protocol :=
FConfig.Protocol;  FConnect.Port := Port;  case FConfig.DataType of  
tdtEmbed       : FConnect.LibraryLocation := Path + 'fbembed.dll';   
tdtFirebird    : FConnect.LibraryLocation := Path + 'fbclient.dll';  
tdtWinMySQL    : FConnect.LibraryLocation := Path + 'libmysql.dll';  
tdtLXMySQL     : FConnect.LibraryLocation := Path + 'libmysqld.dll'; 
end;end; function TDataUtil.ConnectDB: Boolean;var  db: string;begin 
Result := False;  if FConnect.Connected then    DisconnectDB;  if
FConfig.DataType = tdtEmbed then  begin    db :=
GetDBEmbed(Database);    if not FileExists(UTF8ToAnsi(db)) then     
raise Exception.Create('Database "' + db + '" not found!');   
FConnect.Database := db;  end  else    FConnect.Database := Database; 
if (FConnect.Database = '') and (not IsFirebird) then   
FConnect.Database := 'mysql';   PrepareConnect;  FConnect.Connect;  if
Assigned(FOnConnect) then    FOnConnect(Self, FConnect.Connected); 
Result := FConnect.Connected;end; procedure
TDataUtil.DisconnectDB;begin  FQuery.Close;  if FConnect.Connected
then    FConnect.Disconnect;end; function TDataUtil.Connected:
Boolean;begin  Result := FConnect.Connected;end; // Database function
TDataUtil.HasDatabase(aDB: string): Boolean;var  Flg: Boolean;begin 
if DataType = tdtEmbed then  begin    aDB := GetDBEmbed(aDB);   
Result := FileExists(UTF8ToAnsi(aDB));  end  else  begin    Flg :=
Connected;    Result := False;    aDB := UpperCase(aDB);   
DisconnectDB;    FConnect.Database := 'mysql';    PrepareConnect;   
FConnect.Connect;    if Connected then    begin      FQuery.SQL.Text
:= 'SHOW DATABASES';      FQuery.Open;      while not FQuery.Eof do  
    if UpperCase(FQuery.Fields[0].AsString) = aDB then        begin  
      Result := True;          Break;        end        else         
FQuery.Next;      FQuery.Close;    end;    if Flg and (not IsFirebird)
then    begin      FConnect.Database := Database;      ConnectDB;   
end;  end;end; procedure TDataUtil.DatabaseList(DBList:
TStringList);begin  if not Assigned(DBList) then    DBList :=
TStringList.Create;   DBList.Clear;  if DataType <> tdtEmbed then 
begin    FQuery.SQL.Text := 'SHOW DATABASES';    FQuery.Open;    while
not FQuery.Eof do    begin     
DBList.Add(UpperCase(FQuery.Fields[0].AsString));      FQuery.Next;  
end;    FQuery.Close;  end;end; procedure
TDataUtil.CreateDatabase(aDB: string);begin  aDB := UpperCase(aDB); 
if DataType = tdtEmbed then  begin    if not FileExists(Path +
'MSGLIVE.FD_') then      raise Exception.Create('File database dummy
is not found!');    aDB := GetDBEmbed(aDB);    CopyFile(PChar(Path +
'MSGLIVE.FD_'), PChar(aDB), True);  end  else    if not IsFirebird
then    begin      if not FConnect.Connected then      begin       
FConnect.Database := 'mysql';        FConnect.Connect;      end;     
QueryExecSQL('CREATE DATABASE IF NOT EXISTS ' + aDB +                
 ' DEFAULT CHARACTER SET utf8 COLLATE utf8_bin');      if
FConnect.Connected then        FConnect.Disconnect;   
end;end; procedure TDataUtil.DeleteDatabase(aDB: string);begin  if
DataType = tdtEmbed then  begin    aDB := GetDBEmbed(aDB);    if
FileExists(UTF8ToAnsi(aDB)) then    begin      DisconnectDB;     
DeleteFile(PChar(aDB));    end;  end  else    QueryExecSQL('DROP
DATABASE ' + aDB);end; function TDataUtil.OpenDatabase(aDB, aTB:
string; Created: Boolean = True): Boolean;var  ts: TStringList;begin 
Result := False;  Database := aDB;  if not HasDatabase(Database) then 
begin    if not Created then      Exit;    CreateDatabase(Database); 
 if not Connected then      ConnectDB;    if Connected then    begin 
   ts := TStringList.Create;      try       
ts.LoadFromFile(UTF8ToAnsi(aTB));        CreateTable(ts);     
finally        ts.Clear;        FreeAndNil(ts);      end;     
DisconnectDB;    end;  end;  Result := ConnectDB;end;

----------------------------------------------------------------------
jaky2551 · 2018-02-18 03:37

Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i  //
Table function TDataUtil.HasTable(aTB: string): Boolean;begin  aTB :=
UpperCase(aTB);  Result := False;  if IsFirebird then  begin   
FQuery.SQL.Text := 'SELECT 1 FROM RDB$RELATIONS WHERE
RDB$RELATION_NAME=' +                       QuotedStr(aTB);   
FQuery.Open;    Result := (FQuery.RecordCount <> 0);    FQuery.Close; 
end  else  begin    FQuery.SQL.Text := 'SHOW TABLES';    FQuery.Open; 
  while not FQuery.Eof do      if UpperCase(FQuery.Fields[0].AsString)
= aTB then      begin        Result := True;        Break;      end  
  else        FQuery.Next;    FQuery.Close;  end;end; procedure
TDataUtil.TableList(TBList: TStringList);var  tb: TStringList;  tx:
string;  i: Integer;begin  if not Assigned(TBList) then    TBList :=
TStringList.Create;   TBList.Clear;  if IsFirebird then  begin    tb
:= TStringList.Create;    try      FConnect.GetTableNames('', tb);   
 for i := 0 to tb.Count - 1 do      begin        tx :=
UpperCase(tb.Strings[i]);        if (Copy(tx, 1, 3) <> 'RDB') and
(Copy(tx, 1, 3) <> 'MON') then          TBList.Add(tx);      end;   
finally      tb.Clear;      FreeAndNil(tb);    end;  end  else  begin 
  FQuery.SQL.Text := 'SHOW TABLES';    FQuery.Open;    while not
FQuery.Eof do    begin     
TBList.Add(UpperCase(FQuery.Fields[0].AsString));      FQuery.Next;  
end;    FQuery.Close;  end;end; procedure
TDataUtil.CreateTable(TBList: TStringList);  procedure FBTrigger(aTB:
string);  begin    with FConnect do    begin     
ExecuteDirect('CREATE GENERATOR GEN_' + aTB + '_ID;');     
ExecuteDirect('SET GENERATOR GEN_' + aTB + '_ID TO 0;');     
ExecuteDirect('CREATE TRIGGER TR_' + Copy(aTB, 1, 5) + ' FOR ' + aTB
+                    ' ACTIVE BEFORE INSERT POSITION 0' +            
      ' AS BEGIN if (NEW.ID is NULL) then NEW.ID = GEN_ID(GEN_' +    
              aTB + '_ID, 1); END;');    end;  end; var  i: Integer; 
aSQL, tb, ss, fd: string;begin  if FProgress then  begin    ProFrm :=
TProFrm.Create(nil);    ProFrm.MessStr := 'Restoring...';   
ProFrm.MaxValue := TBList.Count;    ProFrm.Show;  end;   aSQL := ''; 
for i := 0 to TBList.Count - 1 do  begin    if FProgress then     
ProFrm.Next;     ss := UpperCase(Trim(TrimLeft(TBList.Strings[i]))); 
 if Pos('//', ss) <> 0 then      ss := Trim(Copy(ss, 1, Pos('//', ss)
- 1));    if (ss <> '') and (ss <> '//') then      if Copy(ss, 1, 2) =
'#N' then      begin        Delete(ss, 1, 2);        tb := ss;     
end      else        if Copy(ss, 1, 2) = '#E' then        begin      
  if tb <> '' then          begin            if not HasTable(tb) then 
          begin              if IsFirebird then              begin   
           FConnect.ExecuteDirect('CREATE TABLE ' + tb +             
      ' (ID INTEGER NOT NULL PRIMARY KEY, ' + aSQL + ')');           
   FBTrigger(tb);              end              else               
QueryExecSQL('CREATE TABLE IF NOT EXISTS ' + tb +                    
     ' (ID INT(11) NOT NULL AUTO_INCREMENT PRIMARY KEY , ' +         
                aSQL + ') ENGINE=MYISAM');            end;         
end;          aSQL := '';          tb := '';        end        else  
    begin          aSQL := AddComma(aSQL);          if IsFirebird
then            aSQL := aSQL + ss          else          begin       
   fd := Copy(ss, 1, Pos(' ', ss) - 1);            Delete(ss, 1, Pos('
', ss));            aSQL := aSQL + fd + ' ' + MySQLField(ss) + ' NOT
NULL';          end;        end;  end;  if FProgress then   
FreeAndNil(ProFrm);end; procedure TDataUtil.DeleteTable(aTB:
string);begin  QueryExecSQL('DROP TABLE ' +
UpperCase(aTB));end; procedure TDataUtil.SetAutoInc(aTB: string; Def:
Integer = 0);begin  aTB := UpperCase(aTB);  if Copy(aTB, 1, 3) = 'TB_'
then    Delete(aTB, 1, 3);  if IsFirebird then    QueryExecSQL('SET
GENERATOR GEN_' + aTB + '_ID TO ' + IntToStr(Def))  else   
QueryExecSQL('ALTER TABLE ' + aTB + ' AUTO_INCREMENT=' +
IntToStr(Def));end; function TDataUtil.GetAutoInc(aTB: string):
Integer;begin  if IsFirebird then  begin    if Copy(aTB, 1, 3) = 'TB_'
then      Delete(aTB, 1, 3);    FQuery.SQL.Text := 'SELECT
RDB$GENERATOR_NAME FROM RDB$GENERATORS ' +              'WHERE
RDB$SYSTEM_FLAG=0 AND RDB$GENERATOR_NAME=' +             
QuotedStr('GEN_' + UpperCase(aTB) + '_ID');    FQuery.Open;    if
FQuery.RecordCount = 0 then      Result := -1    else    begin     
FQuery.Close;      FQuery.SQL.Text := 'SELECT GEN_ID(GEN_' +
UpperCase(aTB) +                         '_ID, 0) FROM RDB$DATABASE'; 
    FQuery.Open;      Result :=
FQuery.FieldByName('GEN_ID').AsInteger;    end;  end  else  begin   
FQuery.SQL.Text := 'SELECT LAST_INSERT_ID() AS ID FROM ' + aTB;   
FQuery.Open;    Result := FQuery.Fields[0].AsInteger;  end; 
FQuery.Close;end; function TDataUtil.NextAutoInc(aTB: string):
Integer;begin  if IsFirebird then    Result := GetAutoInc(aTB) + 1 
else  begin    FQuery.SQL.Text := 'SELECT AUTO_INCREMENT FROM
INFORMATION_SCHEMA.TABLES WHERE TABLE_SCHEMA=' +           
QuotedStr(FConnect.Database) + ' AND TABLE_NAME = ' + QuotedStr(aTB); 
  FQuery.Open;    Result := FQuery.Fields[0].AsInteger;   
FQuery.Close;  end;end;

----------------------------------------------------------------------
jaky2551 · 2018-02-18 03:37

Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i //
Field function TDataUtil.HasField(aTB, aFD: string): Boolean;var  i:
Integer;begin  aFD := UpperCase(aFD);  Result := False;  if IsFirebird
then    FQuery.SQL.Text := 'SELECT FIRST 1 * FROM ' + aTB  else   
FQuery.SQL.Text := 'SELECT * FROM ' + aTB + ' LIMIT 0, 1'; 
FQuery.Open;  for i := 0 to FQuery.Fields.Count - 1 do    if
UpperCase(FQuery.Fields[i].FieldName) = aFD then    begin      Result
:= True;      Break;    end;  FQuery.Close;end; procedure
TDataUtil.InsertField(aTB, aFD, aTY, After: string);var  i, n:
Integer;  s: string;begin  if Connected then  begin    After :=
UpperCase(After);    s := 'ALTER TABLE ' + aTB + ' ADD ' + aFD + ' '; 
  if IsFirebird then    begin      s := s + aTY;      n := -1;      if
After <> '' then      begin        FQuery.SQL.Text := 'SELECT FIRST 1
* FROM ' + aTB;        FQuery.Open;        for i := 0 to
FQuery.Fields.Count - 1 do          if After =
UpperCase(FQuery.Fields[i].FieldName) then          begin            n
:= i + 1;            Break;          end;      end;      if (n <> -1)
then        s := s + ' POSITION ' + IntToStr(n);    end    else   
begin      s := s + MySQLField(aTY);      if After <> '' then        s
:= s + ' AFTER ' + After;    end;    QueryExecSQL(s); 
end;end; procedure TDataUtil.DeleteField(aTB, aFD: string);begin 
QueryExecSQL('ALTER TABLE ' + UpperCase(aTB) + ' DROP ' +
UpperCase(aFD));end; function TDataUtil.FieldIsType(aTB, aFD: string):
TFieldType;var  s: string;begin  Result := ftUnknown;  
FQuery.SQL.Text := 'SELECT TABLE_SCHEMA, TABLE_NAME, COLUMN_NAME,
DATA_TYPE ' +                     'FROM information_schema.COLUMNS
WHERE TABLE_NAME=' +                     QuotedStr(aTB) + ' AND
TABLE_SCHEMA=' +                     QuotedStr(Database) + ' AND
COLUMN_NAME=' +                     QuotedStr(aFD);{  if IsFirebird
then    FQuery.SQL.Text := 'SELECT FIRST 1 FROM ' + aTB  else   
FQuery.SQL.Text := 'SELECT * FROM ' + aTB + ' LIMIT 0,1';}  
FQuery.Open;  if FQuery.RecordCount <> 0 then  begin    s :=
UpperCase(FQuery.FieldByName('DATA_TYPE').AsString);    if (s =
'VARCHAR') or (s = 'CHAR') or (s = 'TEXT') or (s = 'TINYTEXT') or    
 (s = 'MEDIUMTEXT') or (s = 'LONGTEXT') or (s = 'SET') or (s = 'ENUM')
or       (s = 'NCHAR') then      Result := ftString    else if (s =
'INT') or (s = 'BIGINT') or (s = 'INTEGER') or (s = 'TINYINT') or    
 (s = 'SMALLINT') or (s = 'MEDIUMINT') or (s = 'YEAR') then     
Result := ftInteger    else if (s = 'DECIMAL') or (s = 'NUMERIC')
then      Result := ftCurrency    else if (s = 'FLOAT') or (s =
'REAL') or (s = 'DOUBLE') then      Result := ftFloat    else if (s =
'DATE') then      Result := ftDate    else if (s = 'TIME') then     
Result := ftTime    else if (s = 'DATETIME') then      Result :=
ftDateTime    else if (s = 'TIMESTAMP') then      Result :=
ftTimeStamp    else if (s = 'BINARY') or (s = 'VARBINARY') or (s =
'TINYBLOB') or            (s = 'BLOB') or (s = 'MEDIUMBLOB') or (s =
'LONGBLOB') then      Result := ftBlob    else      Result :=
ftUnknown;  end;  FQuery.Close;end; // Something procedure
TDataUtil.QueryExecSQL(aSQL: string);begin  {$IFDEF DEBUGQUERY}   
ShowMessage(aSQL);  {$ENDIF}  FQuery.SQL.Text := aSQL; 
FQuery.ExecSQL;end; procedure TDataUtil.QuerySQL(var rField: string;
var rValue: string; const aField, aValue: string); overload;begin  if
aValue <> '' then  begin    rField := AddComma(rField) + aField;   
rValue := AddComma(rValue) + aValue;  end;end; procedure
TDataUtil.QuerySQL(var rField: string; const aField, aValue: string);
overload;begin  if aValue <> '' then    rField := AddComma(rField) +
aField + '=' + aValue;end; procedure TDataUtil.OpenQuery(aQuery:
TZQuery; aSQL: string = ''; aID: Integer = -1);begin  if
(aQuery.SQL.Text = '') and (aSQL = '') then    raise
Exception.Create('SQL Query not assign!');  if aQuery.Active then   
aQuery.Close;  if aSQL <> '' then    aQuery.SQL.Text := aSQL; 
aQuery.Open;  if aID <> -1 then    aQuery.Locate('ID', aID,
[]);end; procedure TDataUtil.Delete4ID(aQuery: TZQuery; aTB: string;
aID: Integer);begin  aQuery.Close;  QueryExecSQL('DELETE FROM ' + aTB
+ ' WHERE ID=' + IntToStr(aID));  OpenQuery(aQuery);end; procedure
TDataUtil.Search(aQuery: TZQuery; FromTable, InField, ByText: string; 
               tso: TSearchOrder = tsoBefore);var  sso, qry:
string;begin  if Connected then  begin    aQuery.Close;    qry :=
'SELECT * FROM ' + FromTable + ' WHERE ';    if IsFirebird then     
qry := qry + ' POSITION(' + QuotedStr(UpperCase(ByText)) +           
      ' IN UPPER(' + InField + '))>0'    else    begin      case tso
of        tsoBefore    : sso := '%' + ByText;        tsoAfter     :
sso := ByText + '%';      else        sso := '%' + ByText + '%';     
end;      qry := qry + InField + ' LIKE ' + QuotedStr(sso);    end;  
aQuery.SQL.Text := qry + ' ORDER BY ' + InField + ' ASC';   
aQuery.Open;  end;end; function TDataUtil.CanEditOrDelete(aQuery:
TZQuery): Boolean;begin  Result := aQuery.Active and
(aQuery.RecordCount <> 0);end; function TDataUtil.GetHostName:
string;begin  Result := FConfig.HostName;end; function
TDataUtil.GetUserName: string;begin  Result :=
FConfig.UserName;end; function TDataUtil.GetPassword: string;begin 
Result := FConfig.Password;end; function TDataUtil.GetPort:
Word;begin  Result := FConfig.Port;end; function
TDataUtil.GetDatabase: string;begin  Result :=
FConfig.Database;end; function TDataUtil.GetDataType: TDataType;begin 
Result := FConfig.DataType;end; procedure TDataUtil.SetHostName(aHost:
string);begin  FConfig.HostName := aHost;end; procedure
TDataUtil.SetUserName(aUser: string);begin  FConfig.UserName :=
aUser;end; procedure TDataUtil.SetPassword(aPass: string);begin 
FConfig.Password := aPass;end; procedure TDataUtil.SetDatabase(aData:
string);begin  FConfig.Database := aData;end; procedure
TDataUtil.SetDataType(aData: TDataType);begin  FConfig.DataType :=
aData;end; procedure TDataUtil.SetPath(aPath: string);begin  if
Copy(aPath, Length(aPath), 1) <> '\' then    aPath := aPath + '\'; 
FPath := aPath;end; function TDataUtil.GetCodePage(aTB: string):
string;begin  Result := 'utf8';  if not IsFirebird then  begin   
FQuery.SQL.Text := 'SELECT TABLE_COLLATION FROM
information_schema.TABLES where TABLE_SCHEMA=' +           
QuotedStr(Database) + ' AND TABLE_NAME=' +            QuotedStr(aTB); 
  FQuery.Open;    if FQuery.RecordCount <> 0 then      Result :=
Trim(FQuery.Fields[0].AsString);    FQuery.Close;  end;end; procedure
TDataUtil.Backup2File(Filename: string);var  ts: TStringList;  tb:
TStringList;  i, j: Integer;  s: string;  CStream:
TCompressionStream;  FStream: TFileStream;  MStream, DStream:
TMemoryStream;begin  tb := TStringList.Create;  try    TableList(tb); 
  if tb.Count <> 0 then    begin      ts := TStringList.Create;     
try        if FProgress then        begin          ProFrm :=
TProFrm.Create(nil);          ProFrm.MessStr := 'Restoring...';      
  ProFrm.MaxValue := tb.Count;          ProFrm.Show;        end;     
 for i := 0 to tb.Count - 1 do        begin          if FProgress
then            ProFrm.Next;           FQuery.SQL.Text := 'SELECT *
FROM ' + tb.Strings[i] + ' ORDER BY ID ASC';          FQuery.Open;   
     if FQuery.RecordCount <> 0 then          begin           
ts.Add('#N' + tb.Strings[i]);            s := '#F';            for j
:= 0 to FQuery.Fields.Count - 1 do              s := s + '|' +
UpperCase(FQuery.Fields[j].FieldName);            ts.Add(s);         
 s := '#T';            for j := 0 to FQuery.Fields.Count - 1 do      
    begin              s := s + '|';              case
FQuery.Fields[j].DataType of                ftInteger   : s := s +
'I';                ftFloat,                ftCurrency  : s := s +
'F';              else                s := s + 'S';              end; 
          end;            ts.Add(s);            FQuery.First;        
  while not FQuery.Eof do            begin              s := '#D';   
         for j := 0 to FQuery.Fields.Count - 1 do              begin 
             s := s + '|';                case
FQuery.Fields[j].DataType of                  ftInteger   : s := s +
IntToStr(FQuery.Fields[j].AsInteger);                  ftFloat,      
          ftCurrency  : s := s +
FloatToStr(FQuery.Fields[j].AsFloat);                else            
    s := s + UTF8ToAnsi(Trim(FQuery.Fields[j].AsString));            
  end;              end;              ts.Add(s);             
FQuery.Next;            end;            FQuery.Close;            j :=
0;            if IsFirebird then              j :=
GetAutoInc(tb.Strings[i])            else              j :=
NextAutoInc(tb.Strings[i]);            ts.Add('#E|' + IntToStr(j));  
      end;        end;        if FBackupCompress then        begin   
     FStream := TFileStream.Create(UTF8ToAnsi(Filename),
fmOpenReadWrite or fmCreate);          try            DStream :=
TMemoryStream.Create;            MStream := TMemoryStream.Create;    
      try              ts.SaveToStream(MStream);             
MStream.Position := 0;               CStream :=
TCompressionStream.Create(clMax, DStream);              try          
    CStream.CopyFrom(MStream, MStream.Size);              finally    
          FreeAndNil(CStream);              end;             
DStream.Position := 0;              FStream.CopyFrom(DStream,
DStream.Size);            finally              FreeAndNil(MStream);  
        end;          finally            FreeAndNil(FStream);        
  FreeAndNil(DStream);          end;        end        else         
ts.SaveToFile(UTF8ToAnsi(Filename));         if FProgress then       
 FreeAndNil(ProFrm);      finally        ts.Clear;       
FreeAndNil(ts);      end;    end;  finally    tb.Clear;   
FreeAndNil(tb);  end;  if Assigned(FOnBackup) then   
FOnBackup(Self);end; procedure TDataUtil.Restore4File(Filename:
string);const  BufSize = 10240;var  ts: TStringList;  s1, s2, s3, nm,
ty, tb: string;  i, a: Integer;  Buffer: array[0..BufSize - 1] of
Byte;  FStream: TFileStream;  MStream: TMemoryStream;  DStream:
TDecompressionStream;begin  ts := TStringList.Create;  try    if
BackupCompress then    begin      FStream :=
TFileStream.Create(UTF8ToAnsi(Filename), fmOpenRead);      try       
FStream.Position := 0;        MStream := TMemoryStream.Create;       
try          DStream := TDecompressionStream.Create(FStream);        
try            while True do            begin              a :=
DStream.Read(Buffer, BufSize);              if a <> 0 then           
   MStream.WriteBuffer(Buffer, a)              else               
Break;            end;          finally           
FreeAndNil(DStream);          end;          MStream.Position := 0;   
     ts.LoadFromStream(MStream);        finally         
FreeAndNil(MStream);        end;      finally       
FreeAndNil(FStream);      end;    end    else     
ts.LoadFromFile(UTF8ToAnsi(Filename));     if FProgress then    begin 
    ProFrm := TProFrm.Create(nil);      ProFrm.MessStr :=
'Restoring...';      ProFrm.MaxValue := ts.Count;      ProFrm.Show;  
end;     for i := 0 to ts.Count - 1 do    begin      if FProgress
then        ProFrm.Next;       s1 := ts.Strings[i];      if Copy(s1,
1, 2) = '#N' then      begin        Delete(s1, 1, 2);        tb :=
s1;        QueryExecSQL('DELETE FROM ' + tb);      end      else if
Copy(s1, 1, 2) = '#E' then      begin        Delete(s1, 1, 3);       
a := StrToInt(s1);      end      else if Copy(s1, 1, 2) = '#F' then  
  begin        Delete(s1, 1, 3);        nm := '';        while s1 <>
'' do        begin          if nm <> '' then            nm := nm + ',
';          nm := nm + GetToken(s1, '|');        end;      end     
else if Copy(s1, 1, 2) = '#T' then      begin        Delete(s1, 1,
3);        ty := s1;      end      else if Copy(s1, 1, 2) = '#D' then 
    begin        Delete(s1, 1, 3);        s2 := ty;        s3 := ''; 
     while s1 <> '' do        begin          if s3 <> '' then        
  s3 := s3 + ', ';          if Pos('|', s1) <> 0 then          begin 
         if Copy(s2, 1, Pos('|', s2) - 1) = 'S' then              s3
:= s3 + QuotedStr(AnsiToUTF8(Copy(s1, 1, Pos('|', s1) - 1)))         
 else              s3 := s3 + Copy(s1, 1, Pos('|', s1) - 1);         
 Delete(s1, 1, Pos('|', s1));          end          else         
begin            if Copy(s2, 1, Pos('|', s2) - 1) = 'S' then         
   s3 := s3 + QuotedStr(AnsiToUTF8(s1))            else             
s3 := s3 + s1;            s1 := '';          end;          Delete(s2,
1, Pos('|', s2));        end;        QueryExecSQL('INSERT INTO ' + tb
+ ' (' + nm + ') VALUES (' + s3 + ')');      end;      if (a <> 0)
then        SetAutoInc(tb, a);    end;    if FProgress then     
FreeAndNil(ProFrm);  finally    ts.Clear;    FreeAndNil(ts);  end;  if
Assigned(FOnRestore) then    FOnRestore(Self);end; procedure
TDataUtil.LoadConfig(aFile: string);var  fl: file;  r: Integer;begin 
if not FileExists(UTF8ToAnsi(aFile)) then  begin    FConfig.HostName
:= '';    FConfig.UserName := 'SYSDBA';    FConfig.Password :=
'masterkey';    FConfig.Database := '';    FConfig.Protocol :=
'firebird-2.5';    FConfig.Port := 0;    FConfig.DataType :=
tdtEmbed;  end  else  begin    AssignFile(fl, aFile);    Reset(fl,
1);    BlockRead(fl, FConfig, SizeOf(TConfig), r);    CloseFile(fl); 
end;end; procedure TDataUtil.SaveConfig(aFile: string);var  fl: file; 
w: Integer;begin  AssignFile(fl, aFile);  Rewrite(fl, 1); 
BlockWrite(fl, FConfig, SizeOf(TConfig), w); 
CloseFile(fl);end; function TDataUtil.GetDBEmbed(aDB: string):
string;begin  if ExtractFilePath(aDB) = '' then    aDB := Path + aDB; 
if Pos('.FDB', aDB) = 0 then    aDB := aDB + '.FDB';  Result :=
aDB;end; function TDataUtil.IsFirebird: Boolean;begin  Result :=
(DataType = tdtEmbed) or (DataType = tdtFirebird);end; procedure
TDataUtil.LoadFromStream(aQuery: TZQuery; aFD: string; aMemo:
TMemo);var  aStream: TStream;begin  if aQuery.Active then  begin   
aMemo.Lines.Clear;    try      aStream :=
aQuery.CreateBlobStream(aQuery.FieldByName(UpperCase(aFD)), bmRead); 
   aStream.Position := 0;      if aStream.Size <> 0 then       
aMemo.Lines.LoadFromStream(aStream);    finally      aStream.Free;   
end;  end;end; procedure TDataUtil.LoadFromBlob(aQuery: TZQuery; aFD:
string; aImg: TImage);var  aStream: TStream;begin  if aQuery.Active
then  begin    if aQuery.FieldByName(aFD).DataType <> ftBlob then    
raise Exception.Create('Field "' + aFD + '" is not BLOB Field!');   
if aQuery.FieldByName(aFD).IsNull then      with aImg.Canvas do     
begin        Brush.Color := clWhite;        Brush.Style := bsSolid;  
    FillRect(0, 0, aImg.Width, aImg.Height);      end    else     
try        aStream :=
aQuery.CreateBlobStream(aQuery.FieldByName(UpperCase(aFD)), bmRead); 
     aStream.Position := 0;        if aStream.Size <> 0 then         
aImg.Picture.LoadFromStream(aStream);      finally       
aStream.Free;      end;  end;end; procedure
TDataUtil.SaveToBlob(aQuery: TZQuery; aFD: string; aStream:
TStream);begin  if aQuery.Active then    if
aQuery.FieldByName(aFD).DataType <> ftBlob then      raise
Exception.Create('Field "' + aFD + '" is not BLOB Field!')    else   
 TBlobField(aQuery.FieldByName(UpperCase(aFD))).LoadFromStream(aStream
);end; end.

----------------------------------------------------------------------
jaky2551 · 2018-02-18 07:01

Change function TDataUtil.FieldIsType to bellow .-

Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i function
TDataUtil.FieldIsType(aTB, aFD: string): TFieldType;var  s:
string;begin  Result := ftUnknown;   if IsFirebird then   
FQuery.SQL.Text := 'SELECT r.RDB$RELATION_NAME, r.RDB$FIELD_NAME, ' + 
                     'r.RDB$FIELD_SOURCE, ' +                     
 'f.RDB$FIELD_TYPE AS FDType_INT, ' +                     
 'f.RDB$FIELD_SUB_TYPE AS FDSubType ' +                       'FROM
RDB$RELATION_FIELDS r ' +                       'LEFT JOIN RDB$FIELDS
f ' +                       'ON r.RDB$FIELD_SOURCE=f.RDB$FIELD_NAME '
+                       'WHERE r.RDB$RELATION_NAME=' + QuotedStr(aTB)
+                       ' AND r.RDB$FIELD_NAME=' + QuotedStr(aFD) 
else    FQuery.SQL.Text := 'SELECT TABLE_SCHEMA, TABLE_NAME,
COLUMN_NAME, DATA_TYPE ' +                       'FROM
information_schema.COLUMNS WHERE TABLE_NAME=' +                     
 QuotedStr(aTB) + ' AND TABLE_SCHEMA=' +                     
 QuotedStr(Database) + ' AND COLUMN_NAME=' +                     
 QuotedStr(aFD);  FQuery.Open;  if FQuery.RecordCount <> 0 then 
begin    if IsFirebird then    begin      case
FQuery.FieldByName('FDType_INT').AsInteger of        7           : s
:= 'SMALLINT';        8           : s := 'INTEGER';        9         
: s := 'QUAD';        10          : s := 'FLOAT';        11          :
s := 'FLOAT';        // D_FLOAT        12          : s := 'DATE';    
  13          : s := 'TIME';        14          : s := 'CHAR';       
16          : s := 'BIGINT';        27          : s := 'DOUBLE';     
 35          : s := 'TIMESTAMP';        37          : s := 'VARCHAR'; 
      40          : s := 'CSTRING';        261         : s := 'BLOB'; 
    else        s := 'UNKNOWN';      end;      if
FQuery.FieldByName('FDType_INT').AsInteger in [7, 8, 16] then     
begin        case FQuery.FieldByName('FDSubType').AsInteger of       
 1     : s := 'NUMERIC';          2     : s := 'DECIMAL';        end; 
    end;    end    else      s :=
UpperCase(FQuery.FieldByName('DATA_TYPE').AsString);    if (s =
'VARCHAR') or (s = 'CHAR') or (s = 'TEXT') or (s = 'TINYTEXT') or    
 (s = 'MEDIUMTEXT') or (s = 'LONGTEXT') or (s = 'SET') or (s = 'ENUM')
or       (s = 'NCHAR') then      Result := ftString    else if (s =
'INT') or (s = 'BIGINT') or (s = 'INTEGER') or (s = 'TINYINT') or    
 (s = 'SMALLINT') or (s = 'MEDIUMINT') or (s = 'YEAR') then     
Result := ftInteger    else if (s = 'DECIMAL') or (s = 'NUMERIC')
then      Result := ftCurrency    else if (s = 'FLOAT') or (s =
'REAL') or (s = 'DOUBLE') then      Result := ftFloat    else if (s =
'DATE') then      Result := ftDate    else if (s = 'TIME') then     
Result := ftTime    else if (s = 'DATETIME') then      Result :=
ftDateTime    else if (s = 'TIMESTAMP') then      Result :=
ftTimeStamp    else if (s = 'BINARY') or (s = 'VARBINARY') or (s =
'TINYBLOB') or            (s = 'BLOB') or (s = 'MEDIUMBLOB') or (s =
'LONGBLOB') then      Result := ftBlob    else      Result :=
ftUnknown;  end;  FQuery.Close;end;

----------------------------------------------------------------------
JD · 2018-02-18 13:06

Is there a question here somewhere? Are you asking a question about a
problem with your code or are you presenting the tool for appraisal by
the community or are you offering the tool to the community?

JD

----------------------------------------------------------------------
jaky2551 · 2018-02-19 02:55

Yes, I showed the above command code to others who wished to create a
task related to managing the database in his program. In order for his
program to be created, multiple databases can be selected to create
one program, such as in the above command. You can choose a database
as Firebird or MySQL, with the right data center to do it for you. You
can also add additional database options to your needs. Use the
guidelines as I show in this article. And I hope to have someone else
develop it. And publish each other thank you.

----------------------------------------------------------------------
Soner · 2018-02-19 08:28

It looks good, thanks!
Maybe I can change my db from firebird to mysql with less effort.

You should create wiki page for this and can link here:
http://wiki.lazarus.freepascal.org/Category:Databases

----------------------------------------------------------------------
jaky2551 · 2021-05-24 07:38

Update my tool for ZeosDB use Firebird + MySQL.

----------------------------------------------------------------------
Fantablup · 2021-05-29 03:26

I can see some issues you could fix easily.
Maybe I can help.

1. Different version of database can have different and new field
types or older versions can miss the field types. Other differences in
database versions like syntax and others.
2. SQL for different engines and versions in the same unit or class.

You can fix this by creating new class for each database engine. I
mean new class for different versions of the database engine.
This way you will keep every database engine and versions seperated
from each other.
So, when you add a new database engine, you just create a new class
for it, and use the standard classes for using it with the SQL.
This way, you will not touch the finished coding for any other
database engines or versions, and risk bugs in your program

I do it myself this way. I'm  also developing a db management tool.