Archivio

Archive for the ‘DELPHI – EMBARCADERO’ Category

[DELPHI & EMBARCADERO] – Client and Server using TIdTCPServer and TIdTCPClient components

An easy example of a Server and Client using indy components : TIdTCPServer, TIdTCPClientTIdThreadComponent.

 

// *****************************************************************************
//   File    : UServer.pas
//   Project : MicroServer.dpr
//             Easy example of TCP Server with indy component : TidTCPSever
//
//   see indy doc: http://www.indyproject.org/sockets/docs/index.en.aspx
//
// *****************************************************************************
unit UServer;

interface

uses
    Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
    Vcl.Controls, Vcl.Forms, Vcl.Dialogs, IdContext, IdComponent, Vcl.StdCtrls,
    IdBaseComponent, IdCustomTCPServer, IdTCPServer, Vcl.ExtCtrls;

type
    TFServer = class(TForm)
    
        Title         : TLabel;

        btn_start     : TButton;
        btn_stop      : TButton;
        btn_clear     : TButton;

        clients_connected : TLabel;

        IdTCPServer   : TIdTCPServer;
        Label1        : TLabel;
        Panel1        : TPanel;
        messagesLog   : TMemo;

        procedure FormShow(Sender: TObject);
        
        procedure btn_startClick(Sender: TObject);
        procedure btn_stopClick(Sender: TObject);
        procedure btn_clearClick(Sender: TObject);

        procedure IdTCPServerConnect(AContext: TIdContext);
        procedure IdTCPServerDisconnect(AContext: TIdContext);
        procedure IdTCPServerExecute(AContext: TIdContext);
        procedure IdTCPServerStatus(ASender: TObject; const AStatus: TIdStatus;
                                    const AStatusText: string);

        function  getNow():String;
        procedure broadcastMessage(p_message : string);

        private
            { Private declarations }
            
        public
            { Public declarations }
            
    end;
    // ...

    // ... listening port
    const GUEST_CLIENT_PORT    = 20010;

    var
        FServer     : TFServer;


implementation

{$R *.dfm}

// *****************************************************************************
//   EVENT : onShow()
//           ON FORM SHOW
// *****************************************************************************
procedure TFServer.FormShow(Sender: TObject);
begin
    // ... INITIALIZE:

    // ... clear message log
    messagesLog.Lines.Clear;

    // ... zero to clients connected
    clients_connected.Caption := inttostr(0);

    // ... set buttons
    btn_start.visible := true;
    btn_stop.visible  := false;
end;
// .............................................................................


// *****************************************************************************
//   EVENT : btn_startClick()
//           CLICK ON START BUTTON
// *****************************************************************************
procedure TFServer.btn_startClick(Sender: TObject);
begin
    // ... START SERVER:

    // ... clear the Bindings property ( ... Socket Handles )
    IdTCPServer.Bindings.Clear;
    // ... Bindings is a property of class: TIdSocketHandles;

    // ... add listening ports:

    // ... add a port for connections from guest clients.
    IdTCPServer.Bindings.Add.Port := GUEST_CLIENT_PORT;
    // ... etc..


    // ... ok, Active the Server!
    IdTCPServer.Active  := true;

    // ... hide start button
    btn_start.visible   := false;

    // ... show stop button
    btn_stop.visible    := true;

    // ... message log
    MessagesLog.Lines.add('[SERVER] - ' + getNow() + 'STARTED!');

end;
// .............................................................................


// *****************************************************************************
//   EVENT : btn_stopClick()
//           CLICK ON STOP BUTTON
// *****************************************************************************
procedure TFServer.btn_stopClick(Sender: TObject);
begin

    // ... before stopping the server ... send 'good bye' to all clients connected
    broadcastMessage( 'Goodbye my Clients :)');

    // ... stop server!
    IdTCPServer.Active := false;

    // ... hide stop button
    btn_stop.visible   := false;

    // ... show start button
    btn_start.visible  := true;

    // ... message log
    MessagesLog.Lines.add('[SERVER] - ' + getNow() + 'STOPPED!');

end;
// .............................................................................


// *****************************************************************************
//   EVENT : btn_clearClick()
//           CLICK ON CLEAR BUTTON
// *****************************************************************************
procedure TFServer.btn_clearClick(Sender: TObject);
begin
    //... clear messages log
    MessagesLog.Lines.Clear;
end;
// .............................................................................


// *****************************************************************************
//   EVENT : onConnect()
//           OCCURS ANY TIME A CLIENT IS CONNECTED
// *****************************************************************************
procedure TFServer.IdTCPServerConnect(AContext: TIdContext);
var
    Ip          : string;
    Port        : Integer;
    PeerIP      : string;
    PeerPort    : Integer;

    msgToClient : string;
    typeClient  : string;

begin

    // ... OnConnect is a TIdServerThreadEvent property that represents the event
    //     handler signalled when a new client connection is connected to the server.

    // ... Use OnConnect to perform actions for the client after it is connected
    //     and prior to execution in the OnExecute event handler.

    // ... see indy doc:
    //     http://www.indyproject.org/sockets/docs/index.en.aspx


    // ... getting IP address and Port of Client that connected
    Ip        := AContext.Binding.IP;
    Port      := AContext.Binding.Port;
    PeerIP    := AContext.Binding.PeerIP;
    PeerPort  := AContext.Binding.PeerPort;

    // ... message log ...........................................................

    MessagesLog.Lines.add('[SERVER] - ' + getNow() + 'Client Connected!)');


    MessagesLog.Lines.add('           ' + 'Port='     + IntToStr(Port) + ' '
                                      + '(PeerIP='  + PeerIP + '-'
                                      + 'PeerPort=' + IntToStr(PeerPort) + ')');
    // ...

    // ... update number of clients connected
    try
    clients_connected.Caption := IntToStr(IdTCPServer.Contexts.LockList.Count);
    finally
    IdTCPServer.Contexts.UnlockList;
    end;
    // ...

    // ... CLIENT CONNECTED:
    case Port of
    GUEST_CLIENT_PORT   : begin
                            // ... GUEST CLIENTS
                            typeClient := 'GUEST';
                          end;

                          // ...
    end;


    // ... send the Welcome message to Client connected
    msgToClient := 'Welcome ' + typeClient + ' ' + 'Client :)';
    AContext.Connection.IOHandler.WriteLn( msgToClient );

end;
// .............................................................................


// *****************************************************************************
//   EVENT : onDisconnect()
//           OCCURS ANY TIME A CLIENT IS DISCONNECTED
// *****************************************************************************
procedure TFServer.IdTCPServerDisconnect(AContext: TIdContext);
var
    Ip          : string;
    Port        : Integer;
    PeerIP      : string;
    PeerPort    : Integer;

    // msgToClient : string;
    // typeClient  : string;

begin


    // ... getting IP address and Port of Client that connected
    Ip        := AContext.Binding.IP;
    Port      := AContext.Binding.Port;
    PeerIP    := AContext.Binding.PeerIP;
    PeerPort  := AContext.Binding.PeerPort;

    // ... message log ...........................................................
    MessagesLog.Lines.add('[SERVER] - ' + getNow() + 'Client Disconnected!)!');
    MessagesLog.Lines.add('           ' + 'Port='     + IntToStr(Port) + ' '
                                      + '(PeerIP='  + PeerIP + '-'
                                      + 'PeerPort=' + IntToStr(PeerPort) + ')');
    // ...

    // ... update number of clients connected
    try
        clients_connected.Caption := IntToStr(IdTCPServer.Contexts.LockList.Count-1);
    finally
        IdTCPServer.Contexts.UnlockList;
    end;

end;
// .............................................................................


// *****************************************************************************
//   EVENT : onExecute()
//           ON EXECUTE THREAD CLIENT
// *****************************************************************************
procedure TFServer.IdTCPServerExecute(AContext: TIdContext);
var
    Port          : Integer;
    PeerPort      : Integer;
    PeerIP        : string;

    msgFromClient : string;

    msgToClient   : string;

begin

    // ... OnExecute is a TIdServerThreadEvents event handler used to execute
    //     the task for a client connection to the server.

    // ... received a message from a client

    // ... getting IP address, Port and PeerPort from Client that connected
    Port      := AContext.Binding.Port;
    PeerIP    := AContext.Binding.PeerIP;
    PeerPort  := AContext.Binding.PeerPort;


    // ... get message from client
    msgFromClient := AContext.Connection.IOHandler.ReadLn;

    // ... message log ...........................................................
    messagesLog.Lines.add('[CLIENT] - ' + getNow() + msgFromClient);
    MessagesLog.Lines.add('           ' + 'Port='     + IntToStr(Port) + ' '
                                      + '(PeerIP='  + PeerIP + '-'
                                      + 'PeerPort=' + IntToStr(PeerPort) + ')');

    // ...

    // ... process message (request) from Client

    // ...

    // ... send response to Client
    msgToClient := '... response from server :)';

    AContext.Connection.IOHandler.WriteLn( msgToClient );

end;
// .............................................................................


// *****************************************************************************
//   EVENT : onStatus()
//           ON STATUS CONNECTION
// *****************************************************************************
procedure TFServer.IdTCPServerStatus(ASender: TObject; const AStatus: TIdStatus;
                                     const AStatusText: string);
begin

    // ... OnStatus is a TIdStatusEvent property that represents the event handler
    //     triggered when the current connection state is changed...

    // ... message log
    MessagesLog.Lines.add('[SERVER] - ' + getNow() + AStatusText);
end;
// .............................................................................


// *****************************************************************************
//   FUNCTION : getNow()
//              GET NOW DATE TIME
// *****************************************************************************
function TFServer.getNow() : String;
begin
    Result := FormatDateTime('yyyy-mm-dd hh:nn:ss', Now) + ': ';
end;
// .............................................................................


// *****************************************************************************
//   PROCEDURE : broadcastMessage()
//               BROADCAST A MESSAGE TO ALL CLIENTS CONNECTED
// *****************************************************************************
procedure TFServer.broadcastMessage( p_message : string );
var
    tmpList      : TList;
    contexClient : TidContext;
    i            : integer;
begin

    // ... send a message to all clients connected

    // ... get context Locklist
    try
        tmpList := IdTCPServer.Contexts.LockList;
    finally
        // ... unlock list of clients!
        IdTCPServer.Contexts.UnlockList;
    end;

    i := 0;
    while ( i < tmpList.Count ) do begin

        // ... get context ( thread of i-client )
        contexClient := tmpList[i];

        // ... send message to client
        contexClient.Connection.IOHandler.WriteLn(p_message);

        // ... next client thread
        i := i + 1;
    end;

end;
// .............................................................................

end.

 

 

 

// *****************************************************************************
//   File    : UClient.pas
//   Project : MicroServer.dpr
//             Easy example of TCP Client with indy component : TidTCPSever
//
//   see indy doc: http://www.indyproject.org/sockets/docs/index.en.aspx
//
// *****************************************************************************
unit UClient;

interface

uses
    Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
    Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, IdBaseComponent,
    IdComponent, IdTCPConnection, IdTCPClient, IdThreadComponent;

type
    TFClient = class(TForm)

    Label1        : TLabel;
    Label2        : TLabel;

    messageToSend : TMemo;
    messagesLog   : TMemo;

    btn_connect   : TButton;
    btn_disconnect: TButton;
    btn_send      : TButton;

    // ... TIdTCPClient
    IdTCPClient       : TIdTCPClient;

    // ... TIdThreadComponent
    IdThreadComponent : TIdThreadComponent;


    procedure FormShow(Sender: TObject);

    procedure btn_connectClick(Sender: TObject);
    procedure btn_disconnectClick(Sender: TObject);
    procedure btn_sendClick(Sender: TObject);

    procedure IdTCPClientConnected(Sender: TObject);
    procedure IdTCPClientDisconnected(Sender: TObject);

    procedure IdThreadComponentRun(Sender: TIdThreadComponent);

    function  getNow() : String;

    private
        { Private declarations }
    public
        { Public declarations }
    end;

    // ... listening port: GUEST CLIENT
    const GUEST_PORT = 20010;

    var
      FClient     : TFClient;

implementation

{$R *.dfm}


// *****************************************************************************
//   EVENT : onShow()
//           ON SHOW FORM
// *****************************************************************************
procedure TFClient.FormShow(Sender: TObject);
begin

    // ... INITAILIZE

    // ... message to send
    messageToSend.Clear;
    messageToSend.Enabled     := false;

    // ... log
    messagesLog.Clear;

    // ... buttons
    btn_connect.Enabled       := true;
    btn_disconnect.Enabled    := false;
    btn_send.Enabled          := false;

end;
// .............................................................................


// *****************************************************************************
//   EVENT : btn_connectClick()
//           CLICK ON CONNECT BUTTON
// *****************************************************************************
procedure TFClient.btn_connectClick(Sender: TObject);
begin

    // ... try to connect to Server
    try
        IdTCPClient.Connect;

        // ... buttons
        btn_connect.Enabled       := false;
        btn_disconnect.Enabled    := true;
        btn_send.Enabled          := true;

    except
        on E: Exception do begin
            MessagesLog.Lines.add('[CLIENT] - CONNECTION ERROR!' + E.Message );
        end;
    end;

end;
// .............................................................................


// *****************************************************************************
//   EVENT : btn_disconnectClick()
//           CLICK ON DISCONNECT BUTTON
// *****************************************************************************
procedure TFClient.btn_disconnectClick(Sender: TObject);
begin
    // ... is connected ?
    if IdTCPClient.Connected then begin

        // ... disconnect from Server
        IdTCPClient.Disconnect;

        // ... set buttons
        btn_connect.Enabled       := true;
        btn_disconnect.Enabled    := false;
        btn_send.Enabled          := false;

        // ... message to send
        messageToSend.Enabled     := false;
    end;
end;
// .............................................................................


// *****************************************************************************
//   EVENT : onConnected()
//           OCCURS WHEN A CLIENT IS CONNETED
// *****************************************************************************
procedure TFClient.IdTCPClientConnected(Sender: TObject);
begin

    // ... messages log
    MessagesLog.Lines.add('[CLIENT] - ' + getNow() + 'CONNECTED!');

    // ... after connection is ok, run the Thread ... waiting messages 
    //     from server
    IdThreadComponent.Active := true;

    // ... set buttons
    btn_connect.Enabled       := false;
    btn_disconnect.Enabled    := true;
    btn_send.Enabled          := true;

    // ... enable message to send
    messageToSend.Enabled     := true;

end;
// .............................................................................


// *****************************************************************************
//   EVENT : onDisconnected()
//           OCCURS WHEN CLIENT IS DISCONNECTED
// *****************************************************************************
procedure TFClient.IdTCPClientDisconnected(Sender: TObject);
begin
    // ... message log
    MessagesLog.Lines.add('[CLIENT] - ' + getNow() + ' : DISCONNECTED!');
end;
// .............................................................................


// *****************************************************************************
//   EVENT : btn_sendClick()
//           CLICK ON SEND BUTTON
// *****************************************************************************
procedure TFClient.btn_sendClick(Sender: TObject);
begin
    // ... send message to Server
    IdTCPClient.IOHandler.WriteLn(messageToSend.Text);
end;
// .............................................................................


// *****************************************************************************
//   EVENT : onRun()
//           OCCURS WHEN THE SERVER SEND A MESSAGE TO CLIENT
// *****************************************************************************
procedure TFClient.IdThreadComponentRun(Sender: TIdThreadComponent);
var
    msgFromServer : string;
begin
    // ... read message from server
    msgFromServer := IdTCPClient.IOHandler.ReadLn();

    // ... messages log
    messagesLog.Lines.add('[SERVER] - ' + getNow() + msgFromServer);
end;
// .............................................................................


// *****************************************************************************
//   FUNCTION : getNow()
//              GET MOW DATE TIME
// *****************************************************************************
function TFClient.getNow() : String;
begin
    Result := FormatDateTime('yyyy-mm-dd hh:nn:ss', Now) + ': ';
end;
// .............................................................................

end.


… here you can download .dpr files: microserver.zip   –  microclient.zip   

 

 

… relax

 

Annunci

[DELPHI] – Split a string with more than one delimiter

28 gennaio 2015 Commenti disabilitati

Sometimes we need to split a string in tokens delimited by more one delimiter …

… for example, we have a string and we want to split it in tokens delimited by the characters: space, comma, greater than sign, etc.. :


String := 'EXEC SQL
                DECLARE STAFF_LIST CURSOR FOR
                     SELECT EMPID,
                            LNAME,
                            FNAME,
                            SALARY
                       FROM QMT_STAFF
                      WHERE SALARY > 10000
                   ORDER BY EMPID
           END-EXEC.'

… here’s a simple function :

// .............................................................................
//    FUNCTION : SplitStringInTokens
//               SPILT STRING IN TOKENS
//       PARMS : Source          - String to Split
//               DelimiterList   - TStringList of Delimiters
//               TokenList       - TStringList of Tokens
//      RETURN : Count of Tokens
.............................................................................
function TForm1.SplitStringInTokens(const Source: String; const DelimitersList : TStringList; var TokensList : TStringList) : Integer;
var
    SourceString    : String;
    Token           : String;
    Char            : String;
    IndexChar       : Integer;
    IndexDelimiters : Integer;
    FoundDelimiter  : Boolean;
begin

    // ... TRIM STRING
    SourceString := Trim(Source);

    IndexChar := 1;
    Token     := '';
    while ( IndexChar <= Length(SourceString) ) do begin
        // ... GET CURRENT CHAR
        Char := Copy(SourceString, IndexChar, 1);

        // ... CHECK IF THE CHAR IS A DELIMITER (SEARCH IN THE LIST)
        IndexDelimiters := 0;
        FoundDelimiter  := FALSE;
        while (FoundDelimiter = FALSE) and (IndexDelimiters < DelimitersList.Count) do begin
            if (Char = DelimitersList[IndexDelimiters]) then begin
                // ... YES, IT'S A DELIMITER! EXIT
                FoundDelimiter := TRUE;
            end
            else begin
                // ... NO, CONTINUE
                IndexDelimiters := IndexDelimiters + 1;
            end;
        end;

        // ... FOUND A DELIMITER?
        if (FoundDelimiter = TRUE) then begin
            // ... YES, SAVE TOKEN (IF NOT NULL)
            if (Token <> '') then begin
                TokensList.Add(Token);
            end;
            // ... SAVE DELIMITER (IF NOT SPACE)
            if (Char <> ' ') then begin
                TokensList.Add(Char);
            end;
            // ... COPY THE REST OF STRING TO SPLIT
            SourceString := Trim(Copy(SourceString, IndexChar+1, Length(SourceString)));
            Token        := '';
            IndexChar    := 1;
        end
        else begin
            // ... CHAR IS NOT A DELIMITER, ADD CHAR TO TOKEN
            Token := Token + Char;
            // ... INC. INDEX
            IndexChar := IndexChar + 1;
        end;
    end;
    // ... END OF STRING

    // ... ADD LAST TOKEN
    if (Token <> '') then begin
        TokensList.Add(Token);
    end;

    // ... RETURN THE COUNT OF TOKENS
    Result := TokensList.Count;
end;
//..............................................................................

… here’s how to call the function with the arguments :


...
var
    StringToSplit  : String;
    DelimitersList : TStringList;
    TokensList     : TStringList;
    i              : Integer;
begin 

    // ... CREATE THE TOKENS LIST
    TokensList      := TStringList.Create;

    // ... CREATE THE DELIMITERS LIST
    DelimitersList  := TStringList.Create;

    // ... ASSIGN THE STRING TO SPLIT
    StringToSplit   := 'EXEC SQL
                           DECLARE STAFF_LIST CURSOR FOR
                             SELECT EMPID,
                                    LNAME,
                                    FNAME,
                                    SALARY
                               FROM QMT_STAFF
                           ORDER BY EMPID
                        END-EXEC.'

    // ... ADD DELIMITERS TO THE LIST
    DelimitersList.Add(' ');
    DelimitersList.Add(',');
    DelimitersList.Add('>');
    // ... etc..

    // ... CLEAR TOKENS LIST
    TokensList.Clear;

    // ... SPLIT STRING IN TOKENS
    SplitStringInTokens(TextSource, DelimitersList, TokensList);

    // ... SHOW TOKENS LIST
    i := 0;
    While (i < TokensList.Count) do begin
        ShowMessage(TokensList[i]);
        i := i + 1;
    end;    

    // ... end  

 

 

 

… relax

[DELPHI] – Impostare e ripristinare la risoluzione del Video

8 ottobre 2008 Commenti disabilitati

L’esempio di seguito mostra come impostare e ripristinare la risoluzione video richiamando l’API di Windows : ChangeDisplaySettings().


unit USetVideo;

interface

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

type
  TForm1 = class(TForm)
    B_SET: TBitBtn;
    B_RESET: TBitBtn;

    procedure B_SETClick(Sender: TObject);
    procedure B_RESETClick(Sender: TObject);

    function  ImpostaRisoluzioneVideo(pWidth:Integer; pHeight:Integer): Integer;

  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1 : TForm1;

  // ... Variabili globali contenenti i valori della risoluzione
  //     del video prima della nuova impostazione
  OldWidth  : Integer;
  OldHeight : Integer;

implementation
{$R *.DFM}
// .........................................................................
//   PROCEDURE : B_SETClick()
//               CLICK SUL BOTTONE : B_SET
// .........................................................................
procedure TForm1.B_SETClick(Sender: TObject);
begin
    // ... salva la risoluzione del Video Corrente
    OldWidth    := GetSystemMetrics(SM_CXSCREEN);
    OldHeight   := GetSystemMetrics(SM_CYSCREEN);

    // ... imposta la risoluzione Video ( es.: 1024 x 768 )
    ImpostaRisoluzioneVideo(1024, 768);
end;
// .........................................................................

// .........................................................................
//   FUNCTION : ImpostaRisoluzioneVideo()
//              IMPOSTAZIONE DELLA RISOLUZIONE VIDEO
// .........................................................................
function TForm1.ImpostaRisoluzioneVideo(pWidth, pHeight:Integer):Integer;
var
    DeviceMode: TDeviceMode;
begin

    // ... imposta i parametri della struttura TDeviceMode
    DeviceMode.dmSize       := SizeOf(TDeviceMode);
    DeviceMode.dmPelsWidth  := pWidth;
    DeviceMode.dmPelsHeight := pHeight;
    DeviceMode.dmFields     := DM_PELSWIDTH or DM_PELSHEIGHT;

    // ... richiama l'API di Windows per il set della risoluzione.
    //     Il secondo parametro rappresenta il Flag per il set.
    //
    //     Valori :
    //
    //    0                   = La risoluzione e' cambiata dinamicamente
    //    CDS_UPDATEREGISTRY  = La risoluzione e' cambiata dinamicamente e
    //                          sara' aggiornata nel registro
    //                          La modalita' e' memorizzata nel profilo
    //                          utente
    //    CDS_TEST            = Il sistema verifica se e' possibile impostare
    //                          la risoluzione (effettua un TEST)

    // ... per maggiori dettagli vedere l'SDK di Windows.

    Result := ChangeDisplaySettings(DeviceMode, CDS_UPDATEREGISTRY);

    //  ... possibili valori di ritorno :
    //
    //  DISP_CHANGE_SUCCESSFUL	= Impostazione effettuata con successo.
    //  DISP_CHANGE_RESTART	    = Il Sistema deve essere riavviato affinche'
    //                            l'impostazione abbia effetto.
    //  DISP_CHANGE_BADFLAGS	= Valore dei Flags passati errati.
    //  DISP_CHANGE_FAILED	    = Errore durante l'impostazione della
    //                            risoluzione.
    //  DISP_CHANGE_BADMODE	    = Risoluzione Video non supportata.
    //  DISP_CHANGE_NOTUPDATED  = Windows NT solo : non in grado di scrivere
    //                            nel registro.
end;
// .........................................................................

// .........................................................................
//   PROCEDURE : B_RESETClick()
//               CLICK SUL BOTTONE : B_RESET
// .........................................................................
procedure TForm1.B_RESETClick(Sender: TObject);
begin
    // ... Ripristina la risoluzione video con i valori salvati
    ImpostaRisoluzioneVideo(OldWidth, OldHeight);
end;
// .........................................................................

// ... END OF JOB

end.

[DELPHI] – Start e Stop del MySQL Server da un’applicazione Delphi su Pendrive

15 settembre 2008 1 commento

Scenario…

Abbiamo un’applicazione Delphi (desktop) con Data Base MySQL. Vogliamo che l’applicazione possa essere avviata da una pendrive e che i dati (le Tabelle) siano anch’essi memorizzati su pendrive. Ma vogliamo anche che lo stesso MySQL Server sia sulla pendrive e che la nostra applicazione lo avvii alla partenza e lo arresti all’uscita.

… in poche parole vogliamo che tutto (La nostra applicazione, le Tabelle del DataBase  e l’engine del MySQL Server) sia presente sulla pendrive … e che l’utilizzatore della nostra applicazione non debba installare alcun software sul proprio computer! 

 

 Il MySQL Server sulla Pendrive.

Prepariamo l’ambiente sulla pendrive :

1. Creamo un directory nella pendrive (es. \contab) in cui copieremo la nostra applicazione Delphi, l’eseguibile (es. coge.exe)

2. Nella stessa direcotory ( \contab ), copiamo l’intera cartella ( \mysql ) con tutte le sue sottocarelle : \bin, \data, \share e \Docs (possiamo anche, se preferiamo, rinominarla)

3. Nel file di configurazione del MySQL (my.ini), modifichiamo i percorsi assegnati a basedir e datadir

File di Configurazione del MySQL :  my.ini (presente nella cartella \mysql)

...
# CLIENT SECTION
# ----------------------------------------------------------------------
#
# The following options will be read by MySQL client applications.
# Note that only client applications shipped by MySQL are guaranteed
# to read this section. If you want your own MySQL client program to
# honor these values, you need to specify it as an option during the
# MySQL client library initialization.
#
[client]

port=3306

default-character-set=latin1

# SERVER SECTION
# ----------------------------------------------------------------------
#
# The following options will be read by the MySQL Server. Make sure that
# you have installed the server correctly (see above) so it reads this
# file.
#
[mysqld]

# The TCP/IP Port the MySQL Server will listen on
port=3306

#Path to installation directory. All paths are usually resolved relative to this.
basedir="\mysql\"

#Path to the database root
datadir="\mysql\data\"
...

Le Funzioni per lo Start e Stop del MySQL Sever.

Di seguito sono riportate le quattro funzioni per la gestione dell’avvio e l’arresto del MySQL Server.
Le funzioni SP_MySQLStart() e SP_MySQLStop() effettuano rispettivamente l’avvio e l’arresto del MySQL Server, la funzione SP_ExecProcess() avvia un processo richiamando a sua volta l’API di Windows CreateProcess(), ed infine la funzione SP_CheckProcess() controlla se un processo è in esecuzione o meno.

… le funzioni sono state raccolte in una unit : MySQLServer_Lib.pas, così da poter essere facilmente incluse ed utilizzate nei propri progetti…


unit MYSQLServer_Lib;

interface

Uses Forms,SysUtils, DBTables, Classes, DB, Dialogs, StdCtrls,
        WinTypes, WinProcs;

   // ... funzioni per lo Start e Stop del servizio MySQL Server
   function  SP_MySQLStart(var pHandle_Server:THandle):Integer;
   function  SP_MySQLStop(pHandle_Server:THandle) :Integer;

   function  SP_ExecProcess(pApplication, pCommandLine, pDirectory : string): THandle;
   function  SP_CheckProcess(pHandle: THandle): Boolean;

const

   // ... costanti relative ai valori di ritorno delle funzioni
   //     di Strat e Stop.
   ENGINE_STARTED             = 9001;
   ENGINE_RUNNING             = 9002;
   ENGINE_START_ERROR         = 9003;

   ENGINE_STOPPED             = 9004;
   ENGINE_NOT_RUNNING         = 9005;
   ENGINE_STOP_ERROR          = 9006;

implementation

//--------------------------------------------------------------------------
// FUNCTION  : SP_MySQLStart()
//             La Funzione effettua lo Start del MySQL Server (mysql-nt.exe)
//
// PARAMETRI : Nessuno
//
// RETURN    : La funzione ritorna uno dei valori interi dichiarati
//             come const :
//              ENGINE_STARTED      = 9001 - MySQL Server avviato.
//              ENGINE_RUNNING      = 9002 - MySQL Server gia' in esecuzione.
//              ENGINE_START_ERROR  = 9003 - Errore durante l'avvio.
//--------------------------------------------------------------------------
function SP_MySQLStart(var pHandle_Server:THandle):Integer;
var
  Start_Code        : Integer;

  PathEngine        : string;

  ApplicationName   : string;
  CommandLine       : string;
  CurrentDirectory  : string;
begin

  // ... directory corrente dell'Applicazione Delphi
  //     ( da dove l'applicazione è stata avviata)
  PathEngine        := GetCurrentDir;

  // ... assegna : Nome Applicazione, Linea di Comando e Directory di lavore
  ApplicationName   := PathEngine + '\DataBase\bin\mysqld-nt.exe';
  CommandLine       := '--defaults-file="\DataBase\my.ini"';
  CurrentDirectory  := PathEngine + '\DataBase';

  // ... controlla se il Processo ( il MySQL Engine è già in esecuzione )
  if SP_CheckProcess(pHandle_Server) = true then begin
     // ... il processo MySQL Server è gia' in esecuzione
     Start_Code := ENGINE_RUNNING;
     // ShowMessage('MYSQL Server gia'' in esecuzione');
  end
  else begin
     // ShowMessage('MYSQL Server non in esecuzione, START...');

     // ... Start dell'MSQL Engine!
     pHandle_Server := SP_ExecProcess(ApplicationName, CommandLine, CurrentDirectory);
     // ... Sleep ( attendi un po' )
     sleep(3000);
     if pHandle_Server <> 0 then begin
        // ... Ok, avviato !
        Start_Code := ENGINE_STARTED;
     end
     else begin
        // ... errore durante l'avvio del servizio MySQL Server
        Start_Code := ENGINE_START_ERROR;
        // ShowMessage('Errore durante lo START!');
     end;
  end;
  // ... ritorna lo Start Code relativo
  Result := Start_Code;
end;
//--------------------------------------------------------------------------

//--------------------------------------------------------------------------
//
// FUNCTION  : SP_MySQLStop()
//             La Funzione effettua lo Stop del servizion MySQL Server
//
// PARAMETRI : Nessuno
//
// RETURN    : La funzione ritorna uno dei valori interi dichiarati
//             come const :
//              ENGINE_STOPPED      = 9004 - MySQL Server arrestato.
//              ENGINE_NOT_RUNNING  = 9005 - MySQL Server non in esecuzione.
//              ENGINE_STOP_ERROR   = 9005 - Errore durante l'arresto.
//
//--------------------------------------------------------------------------
function SP_MySQLStop(pHandle_Server:THandle):Integer;
var
  Stop_Code         : Integer;

  Handle_Admin      : THandle;

  PathEngine        : string;

  ApplicationName   : string;
  CommandLine       : string;
  CurrentDirectory  : string;

  contatore         : Integer;
begin

  // ... directory dell'Applicazione Delphi ( da dove è stata avviata )
  PathEngine        := GetCurrentDir;

  // ... avviamo il msqladmin.exe che ci consentirà di arretsare il MySQL Engine
  //     (mysqld-nt.exe)

  // ... assegna : Nome Applicazione, Linea di Comando e Directory di lavoro
  ApplicationName   := PathEngine + '\DataBase\bin\mysqladmin.exe';

  // ... User e Password (sono impostate a root root ...impostare le proprie)
  CommandLine       := '-u root -proot shutdown';

  // ... direcoty di lavoro
  CurrentDirectory  := PathEngine + '\DataBase';

  // ... controlla se il Processo ( il MySQL Engine è in esecuzione )
  if SP_CheckProcess(pHandle_Server) = FALSE then begin
     // ... esci!
     Stop_Code := ENGINE_NOT_RUNNING;
     // ShowMessage('MySQL NON E'' IN ESECUZIONE');
  end
  else begin
     // ShowMessage('MySQL E'' IN ESECUZIONE, STOP...');

     // ... per fermare il servizio MySQL Server, dobbiamo avviare il servizio
     // mysqladmin.exe indicando, nella riga di comando ( CommandLine ),
     // ... lo shutdown del servizio con la relativa utenza e password
     Handle_Admin := SP_ExecProcess(ApplicationName, CommandLine, CurrentDirectory);

     if Handle_Admin <> 0 then begin
        // ... il servizio myqladmin.exe e' avviato,
        // ... ora attendi che il mysqladmin arresti il MySQL Engine (msqld-nt.exe)
        contatore := 10;
        repeat
            // ... decrementa il contatore
            dec(contatore);
            // ... controlla se il Processo è ancora attivo
            if SP_CheckProcess(pHandle_Server) = TRUE then begin
               // ... si, ancora attivo ... attendi un po'
               Sleep(3000);
            end;
        until (contatore < 1) or (Handle_Admin = 0);

        // ... chiudi l'Handle del msqladmin.exe
        CloseHandle(Handle_Admin);
        // ShowMessage('MySQl Server stopped');
        Stop_Code := ENGINE_STOPPED;
        // ShowMessage('STOPPED OK !');
     end
     else begin
        // ... errore durante l'avvio del servizio msqadmin.exe...
        //     (che avrebbe dovuto fermare il mysqld-nt.exe)
        Stop_Code := ENGINE_STOP_ERROR;
        // ShowMessage('ERRORE DURANTE LO STOP !');
     end;
  end;

  // ... ritorna lo Stop Code relativo
  Result := Stop_Code;
end;
//--------------------------------------------------------------------------

//--------------------------------------------------------------------------
//
// FUNCTION  :  SP_ExecProcess()
//              La Funzione avvia un'applicazione creandone il
//              processo relativo.
//              Richiama l'API di Windows CreateProcess().
//
// PARAMS    :  Sono previsti tre parametri in ingresso :
//
//              pApplication = Nome del l'applicazione che
//                             da avviare.
//
//              pCommandLine = Linea di comando.
//                             (eventuali parametri e flags
//                              da passare all'applicazione
//                              da avviare).
//
//              pDirectory   = Directory di lavoro
//                             dell'applicazione.
//
// RETURN    :  La funzione ritorna l'handle relativo al processo
//              avviato.
//
//--------------------------------------------------------------------------
function SP_ExecProcess(pApplication, pCommandLine,
                        pDirectory : string): THandle;
var
  // ... struttura contenete le Info di StartUp dell'applicazione
  //     da avviare.
  //     (vedere la documentazione Windows SDK Developer's Reference)
  sInfo          : TStartupInfo;

  // ... struttura contenete le Info del processo avviato.
  //     (vedere la documentazione Windows SDK Developer's Reference)
  pInfo          : TProcessInformation;

  // ... handle del processo
  Handle_Process : THandle;

  // ... flag che indica se il processo e' stato creato o meno
  CreatedOK      : Boolean;

begin

  // ... inizializza la Struttura sInfo
  FillChar(sInfo, SizeOf(sInfo), 0);

  // ... ora inizializza la Struttura pInfo
  FillChar(pInfo, SizeOf(pInfo), 0);

  // ... l'elemento .cb (della struttura TStartupInfo) indica
  //     la taglia, in bytes, della struttura...
  // ... assegnagli il valore!
  sInfo.cb := SizeOf(TStartupInfo);

  // ... l'elemento .wShowWindow indica SE e COME deve apparire
  //     la Window relativa al processo che stiamo avviando.
  // ... voglio che il MySQL Sever parta senza che appaia
  //     la finestra del prompt dei comandi.
  sInfo.wShowWindow := SW_HIDE;
  sInfo.dwFlags     := STARTF_USESHOWWINDOW;

  // ... inizializza a FALSE il Flag di creazione del processo
  CreatedOK := FALSE;

  // ... richiama l'API di Windows CreateProcess()
  CreatedOK := CreateProcess(nil, PChar(pApplication + ' ' +
                                        pCommandLine),
                                        nil,
                                        nil,
                                        False,
                                        CREATE_NEW_PROCESS_GROUP +
                                        HIGH_PRIORITY_CLASS,
                                        nil,
                                        PChar(pDirectory),
                                        sInfo,
                                        pInfo);

  // ... test del valore di ritorno della funzione CreateProcess()
  if (createdOK = TRUE) then begin
     // ... ok! il processo e' stato creato...
     // ... ritorna l'id del processo
     Handle_Process := pInfo.hProcess;
  end
  else begin
     // ... il processo non e' stato creato !
     // ... ritorna 0 !
     Handle_Process := 0;
  end;
  //
  Result := Handle_Process;
end;
//--------------------------------------------------------------------------
//--------------------------------------------------------------------------
//
// FUNCTION  : SP_CheckProcess()
//             La Funzione controlla se un processo è attivo o meno
//
// PARAMETRI : E' previsto un unico parametro in ingresso :
//             pHandle  =  L'identificativo (Handle) del processo
//                         ...il valore dell'Handle è quello ritornato dalla
//                         funzione SP_ExecProcess()
//
// RETURN    : La funzione ritorna un valore Booleano :
//             True  = se il processo è attivo
//             False = se il processo non è attivo
//
//--------------------------------------------------------------------------
function SP_CheckProcess(pHandle: THandle): Boolean;
var
  Check_Flag : Boolean;
  ExitCode   : Cardinal;
begin

  // ... assegna FALSE al valore di ritorno
  Check_Flag := FALSE;

  // ... test sull'Handle del processo
  if (pHandle <> 0) then begin
     // ... è diverso da ZERO... allora :
     // ... richiamo dell'API di Windows GetExitCode() che valorizzerà
     //     ExitCode e ritornerà TRUE se la funzione ha successo.
     if (GetExitCodeProcess(pHandle, ExitCode) = TRUE) then begin
        // ... analisi dell'ExitCode
        if (ExitCode = STILL_ACTIVE) then begin
           // ... il processo è ancora attivo
           // showmessage('ancora attivo');
           Check_Flag := TRUE;
        end
        else begin
           // ... il processo non e' attivo
           // showmessage('non attivo');
           CloseHandle(pHandle);
           pHandle    := 0;
           // ... il processo non e' attivo
           Check_Flag := FALSE;
        end;
     end
     else begin
        // ShowMessage('Valore della ExitCodeProcess = FALSE (insuccesso) ');
     end;
  end
  else begin
     // ShowMessage('Halndle da controllare e'' ZERO');
  end;

  // ... ritorna il Check Flag
  Result := Check_Flag;
end;
//--------------------------------------------------------------------------

end.

La Form per il test delle Funzioni…

Una semplice Form per effettuare il test delle funzioni di Start e Stop del MySQL Server.
La Form prevede solo due bottoni, uno per l’avvio e l’altro per l’arresto del MySQL Server, ed una Label in cui sarà visualizzato il messaggio relativo…


unit UMySQLServer_Test;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Buttons,

  MySQLServer_Lib;

type
  TFMySQLServer_Test = class(TForm)
    B_START : TBitBtn;
    B_STOP  : TBitBtn;

    MSG     : TLabel;

    procedure B_STARTClick(Sender: TObject);
    procedure B_STOPClick(Sender: TObject);

    procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);

  private
    { Private declarations }
  public
    { Public declarations }

  end;

var
  FMySQLServer_Test    : TFMySQLServer_Test;

  //  ... identificativo del processo relativo al MySQL Server
  MySQL_Server_Handle : THandle;

implementation

{$R *.DFM}

//--------------------------------------------------------------------------
//   EVENTO : FormCreate
//--------------------------------------------------------------------------
procedure TFMySQLServer_Test.FormCreate(Sender: TObject);
begin
  // ... inizializza a 0
  MySQL_Server_Handle := 0;
end;
//--------------------------------------------------------------------------

//--------------------------------------------------------------------------
//   EVENTO : FormShow
//--------------------------------------------------------------------------
procedure TFMySQLServer_Test.FormShow(Sender: TObject);
begin
  // ... messaggio a video
  MSG.Caption := '';
end;
//--------------------------------------------------------------------------
//--------------------------------------------------------------------------
//   EVENTO : Click sul BOTTONE START_ENGINE
//--------------------------------------------------------------------------
procedure TFMySQLServer_Test.B_STARTClick(Sender: TObject);
var
  Start_Code : Integer;
begin

  // Start MySQL Server

  // ... imposta il Cursore a clessidra
  Screen.Cursor := crHourglass;

  // ... eventuale messaggio di attesa
  MSG.Caption := 'Start MySQL Server ...please wait';

  // ... forza la visualizzazione del messaggio
  Application.ProcessMessages;

  // ... richiamo della Funzione di Start del MySQL Server
  Start_Code := SP_MySQLStart(MySQL_Server_Handle);

  // ... analisi del Codice di ritorno :
  case Start_Code of
           ENGINE_STARTED : begin
                               MSG.Caption := 'MySQL Server started!';
                            end;

           ENGINE_RUNNING : begin
                               MSG.Caption := 'MySQL Server running';
                            end;

       ENGINE_START_ERROR : begin
                               MSG.Caption := 'MySQL Server Start Error!';
                            end;
  end;

  // ... ripristina il Cursore
  Screen.Cursor := crDefault;
end;
//--------------------------------------------------------------------------
//--------------------------------------------------------------------------
//   EVENTO : Click sul BOTTONE STOP_ENGINE
//--------------------------------------------------------------------------
procedure TFMySQLServer_Test.B_STOPClick(Sender: TObject);
var
  Stop_Code : Integer;
begin

  // ... Stop MYSQL Server :

  // ... imposta il Cursore a clessidra
  Screen.Cursor := crHourglass;

  // ... eventuale messaggio di attesa
  MSG.Caption := 'Stop MySQL Server ...please wait';

  // ... forza la visualizzazione del messaggio
  Application.ProcessMessages;

  // ... richiamo della Funzione di Start del MySQL Server
  Stop_Code   := SP_MySQLStop(MySQL_Server_Handle);

  // ... analisi del Codice di ritorno :
  case Stop_Code of
          ENGINE_STOPPED : begin
                               MSG.Caption := 'MySQL Server stopped!';
                           end;

      ENGINE_NOT_RUNNING : begin
                               MSG.Caption := 'MySQL Server not running';
                           end;

       ENGINE_STOP_ERROR : begin
                               MSG.Caption := 'MySQL Server Stop Error!';
                           end;
  end;

  // ... ripristina il Cursore
  Screen.Cursor := crDefault;
end;
//--------------------------------------------------------------------------

end.