Italian community of Lazarus and Free Pascal

...

type
  { CallBack connection test}

  TNotifyOnTestConnection = function(const DbType,HostName,DbName,UserName,Password: string): boolean of object;

  { TfmSimpleDbConnectionDialog }

  TfmSimpleDbConnectionDialog = class(TForm)
    BitBtn1: TBitBtn;
    BitBtn2: TBitBtn;
    Button1: TButton;
    edDbName: TEdit;
    edDbType: TComboBox;
    edHostName: TEdit;
    edPassword: TEdit;
    edUserName: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    { private declarations }
    FOnTestConnection: TNotifyOnTestConnection;
    procedure DoTestConnection;
  public
    { public declarations }
    procedure InitConnectionSettings(const DbType,HostName,DbName,UserName,Password: string);
    procedure AddDbTypes(const ATypes: array of string);
    property OnTestConnection: TNotifyOnTestConnection write FOnTestConnection;
  end;


implementation

...

procedure TfmSimpleDbConnectionDialog.Button1Click(Sender: TObject);
begin
  DoTestConnection
end;


procedure TfmSimpleDbConnectionDialog.FormShow(Sender: TObject);
begin
  Button1.Enabled:=Assigned(FOnTestConnection);
end;

procedure TfmSimpleDbConnectionDialog.DoTestConnection;
begin
  if Assigned(FOnTestConnection) then
     FOnTestConnection(edDbType.Text,edHostName.Text,edDbName.Text,edUserName.Text,edPassword.Text);
end;

procedure TfmSimpleDbConnectionDialog.InitConnectionSettings(const DbType,
  HostName, DbName, UserName, Password: string);
var i: integer;
begin
   if DbType <> '' then begin
      i := edDbType.Items.IndexOf(DbType);
      if i < 0 then begin
         AddDbTypes([DbType]);
          i := edDbType.Items.IndexOf(DbType);
      end;
      edDbType.ItemIndex := i;
   end else
      if edDbType.Items.Count > 0 then
         edDbType.ItemIndex := 0;

   edDbName.Text := DbName;
   edHostName.Text := HostName;
   edUserName.Text := UserName;
   edPassword.Text := Password;
end;

procedure TfmSimpleDbConnectionDialog.AddDbTypes(const ATypes: array of string);
var s: string;
begin
   edDbType.Items.Clear;
   for s in ATypes do
      edDbType.Items.Add(s);
end;

end.

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
   ... 
   sqldb,   // unit contenente TSqlConnector
   ...

type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    SQLConnector1: TSQLConnector;
    procedure Button1Click(Sender: TObject);
  private
    { private declarations }
    function TestConnection(const DbType,HostName,DbName,UserName,Password: string): boolean;
  public
    { public declarations }
    function ConfiguraConnessione: boolean;
  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

uses uSimpleDbConnectionDialog,
     IBConnection,     // obbligatorio per connettersi a firebird
     sqlite3conn,      // obbligatorio per connettersi a sqllite
     oracleconnection  // obbligatorio per connettersi a oracle
     ;

{ TForm1 }

procedure TForm1.Button1Click(Sender: TObject);
begin
   if ConfiguraConnessione then
      ShowMessage('Connessione OK')
   else
     ShowMessage('Connessione non riuscita');
end;

function TForm1.TestConnection(const DbType, HostName, DbName, UserName,
  Password: string): boolean;
begin
  SQLConnector1.Close;
  SQLConnector1.ConnectorType := DbType;
  SQLConnector1.HostName := HostName;
  SQLConnector1.DatabaseName := DbName;
  SQLConnector1.UserName := UserName;
  SQLConnector1.Password := Password;
  result := FALSE;
  try
     SQLConnector1.Open;
     ShowMessage('Test connessione riuscito!');
     SQLConnector1.Close(TRUE);
     result := TRUE;
  except
     on e: exception do begin
        MessageDlg(Application.Title,
                  'Errore durante la connessione!' + LineEnding + LineEnding +
                  e.Message, mtError, [mbOk], 0);
     end;
  end;
end;

function TForm1.ConfiguraConnessione: boolean;
begin
  result := FALSE;
  with TfmSimpleDbConnectionDialog.Create(Application) do
     try
        // il test della connessione lo fa il chiamante
        // assegnamo quindi il puntatore alla procedura di CallBack
        OnTestConnection := @TestConnection;

        // tipi di connessioni ammesse dal dialog
        AddDbTypes(['Firebird','SqlLite','Oracle']);

        // inizializzazione dei campi di edit
        // ad esempio si possono estrarre i valori da un file do configurazione
        InitConnectionSettings('Firebird',
                               'digitare IP o hostname',
                               'nome del database',
                               'nome utente',
                               '');

        if ShowModal = mrOk then begin
           SqlConnector1.ConnectorType := edDbType.Items[edDbType.ItemIndex];
           SqlConnector1.HostName := edHostName.Text;
           SqlConnector1.DatabaseName := edDbName.Text;
           SqlConnector1.UserName := edUserName.Text;
           SqlConnector1.Password := edPassword.Text;
           try
              SqlConnector1.Open;
              result := TRUE;
           except
              on e: exception do begin
                 MessageDlg(Application.Title,
                           'Errore durante la connessione!' + LineEnding + LineEnding +
                           e.Message, mtError, [mbOk], 0);
              end;
           end;

        end;
     finally
       Free;
     end;

end;

end.

function TestConnection(const DbType,HostName,DbName,UserName,Password: string): boolean;

        // il test della connessione lo fa il chiamante
        // assegnamo quindi il puntatore alla procedura di CallBack
        OnTestConnection := @TestConnection;