Developpez.com - Delphi
X

Choisissez d'abord la catégorieensuite la rubrique :

Nono40.developpez.com
Le petit coin du web de Nono40
SOURCES TESTS DELPHI WIN32 AUTOMATISMES DELPHI .NET QUICK-REPORT
Retour à l'accueil
15 - CLIENTSOCKET / SERVERSOCKET

PRÉSENTATION : Exemple de transfert de fichier avec les composants TServerSocket et TClientSocket.
ZIP : Téléchargez le zip APERÇUS :

NOTES : Le transfert de fichier n'est pas optimisé, mais ce n'était pas le but de cet exemple qui est en premier de montrer l'utilisation des composants.
Utilisation :
Sur le serveur il suffit d'appuyer sur le bouton ouvrir.
Sur un client il faut renseigner l'adresse ip du serveur et ensuite appuyer sur le bouton "Envoyer".

Le client se connecte au serveur, transfert le fichier par bloc et se déconnecte. Le serveur n'accepte qu'un seul fichier à la fois, ce n'est pas une limitation du TServerSocket mais de l'application.

CODE :
Unit Unit1;

Interface

Uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ScktComp, ExtCtrls;

Type
  TForm1 = Class(TForm)
    Client: TClientSocket;
    Serveur: TServerSocket;
    GroupBox1: TGroupBox;
    btnOpen: TButton;
    btnClose: TButton;
    MemoServeur: TMemo;
    GroupBox2: TGroupBox;
    btnEnvoyer: TButton;
    btnStop: TButton;
    Edit1: TEdit;
    Ouvrir: TOpenDialog;
    MemoClient: TMemo;
    RetardDebut: TTimer;
    Procedure btnOpenClick(Sender: TObject);
    Procedure btnCloseClick(Sender: TObject);
    Procedure ServeurClientConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    Procedure ServeurClientDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    Procedure ServeurClientError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; Var ErrorCode: Integer);
    Procedure ServeurClientRead(Sender: TObject; Socket: TCustomWinSocket);
    Procedure ClientConnect(Sender: TObject; Socket: TCustomWinSocket);
    Procedure ClientDisconnect(Sender: TObject; Socket: TCustomWinSocket);
    Procedure ClientError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; Var ErrorCode: Integer);
    Procedure btnEnvoyerClick(Sender: TObject);
    Procedure ClientRead(Sender: TObject; Socket: TCustomWinSocket);
    Procedure btnStopClick(Sender: TObject);
    Procedure RetardDebutTimer(Sender: TObject);
  Private
    { Déclarations privées }
  Public
    { Déclarations publiques }
  End;

Var
  Form1: TForm1;


Implementation

{$R *.dfm}

//**************************************************************************************
//
//  Principe :
//    le fichier envoyé en coupé en tranches de taille identiques et e transmises au serveur
//    dans l'ordre du fichier.
//
//    - Le client se connecte au serveur.
//    - Si la connection est OK alors il envoie un trame du type ci-dessous avec ttType=1
//      signalant qu'il s'agit du nom du fichier. ttNomFichier est alors le nom du fichier
//      transféré.
//    - Si le serveur accepte la demande, alors le fichier est envoyé par morceau avec le même
//      type de trame. ttType = 2 pour signaler qu'il s'agit un morceau du fichier. ttDebut
//      donne l'adresse du bloc dans le fichier et ttLong la taille du bloc.
//    - Le client se deconnecte, ce qui ferme le fichier sur le serveur.
//
//**************************************************************************************



//**************************************************************************************
//  Procédure d'affichage en clair des erreurs socket
//  merci à djtexas
Function MessageErreurSocket( ErrorEvent: TErrorEvent; Var ErrorCode: Integer):String;
Var
    ErrorMsg: String;
Begin
    // définition du message d'erreur en fonction du code d'erreur
    Case ErrorCode Of
        10004 : ErrorMsg := 'Interrupted Function call.';
        10013 : ErrorMsg := 'Permission Refusée.';
        10014 : ErrorMsg := 'Mauvaise adresse.';
        10022 : ErrorMsg := 'Arguments Invalides.';
        10024 : ErrorMsg := 'Trop de fichiers ouverts.';
        10035 : ErrorMsg := 'Resource temporarily unavailable.';
        10036 : ErrorMsg := 'Operation en cours.';
        10037 : ErrorMsg := 'Operation déjà en cours.';
        10038 : ErrorMsg := 'Socket operation On non-socket.';
        10039 : ErrorMsg := 'Destination address required.';
        10040 : ErrorMsg := 'Message trop long.';
        10041 : ErrorMsg := 'Protocol wrong Type For socket.';
        10042 : ErrorMsg := 'Bad protocol option.';
        10043 : ErrorMsg := 'Protocol Not supported.';
        10044 : ErrorMsg := 'Socket Type Not supported.';
        10045 : ErrorMsg := 'Operation Not supported.';
        10046 : ErrorMsg := 'Protocol family Not supported.';
        10047 : ErrorMsg := 'Address family Not supported by protocol family.';
        10048 : ErrorMsg := 'Address already In use.';
        10049 : ErrorMsg := 'Cannot assign requested address.';
        10050 : ErrorMsg := 'Network Is down.';
        10051 : ErrorMsg := 'Network Is unreachable.';
        10052 : ErrorMsg := 'Network dropped connection On reset.';
        10053 : ErrorMsg := 'Software caused connection abort.';
        10054 : ErrorMsg := 'Connection reset by peer.';
        10055 : ErrorMsg := 'No buffer space available.';
        10056 : ErrorMsg := 'Socket Is already connected.';
        10057 : ErrorMsg := 'Socket Is Not connected.';
        10058 : ErrorMsg := 'Cannot send after socket shutdown.';
        10060 : ErrorMsg := 'Connection timed Out.';
        10061 : ErrorMsg := 'Connection refused.';
        10064 : ErrorMsg := 'Host Is down.';
        10065 : ErrorMsg := 'No route To host.';
        10067 : ErrorMsg := 'Too many processes.';
        10091 : ErrorMsg := 'Network subsystem Is unavailable.';
        10092 : ErrorMsg := 'WINSOCK.DLL version Out Of range.';
        10093 : ErrorMsg := 'Successful WSAStartup Not yet performed.';
        10094 : ErrorMsg := 'Graceful shutdown In progress.';
        11001 : ErrorMsg := 'Host Not found.';
        11002 : ErrorMsg := 'Non-authoritative host Not found.';
        11003 : ErrorMsg := 'This Is a non-recoverable error.';
        11004 : ErrorMsg := 'Valid name, no data Record Of requested Type.';
    Else
        // erreur inconnue
        ErrorMsg := 'Unknown socket error.';
    End;
    // mise en forme de la signification de l'erreur
    ErrorMsg := 'Socket Error n°' + IntToStr(ErrorCode) + ' : ' + ErrorMsg;
    // l'erreur est traitée
    ErrorCode := 0;
    // définition du type d'erreur
    Case ErrorEvent Of
        eeSend       : ErrorMsg := 'Writing '       + ErrorMsg;
        eeReceive    : ErrorMsg := 'Reading '       + ErrorMsg;
        eeConnect    : ErrorMsg := 'Connecting '    + ErrorMsg;
        eeDisconnect : ErrorMsg := 'Disconnecting ' + ErrorMsg;
        eeAccept     : ErrorMsg := 'Accepting '     + ErrorMsg;
    Else
        // erreur inconnue
        ErrorMsg := 'Unknown ' + ErrorMsg;
    End;
    Result:=ErrorMsg;
End;
//
//**************************************************************************************



//**************************************************************************************
//    Structure de la trame utilisée pour les échanges
//
Const
  TailleBloc = 256;
Type
  TIPTrame=Packed Record
    Case ttType:Integer Of                          // ttType précise le type de la trame
                                                    //  =1 quand c'est un nom de fichier
                                                    //  =2 quand c'est un morceau du fichier
    1:(
        ttNomFichier:String[255];                   // Nom du fichier
      );
    2:( ttDebut : Integer;                          // Adresse de début des données dans le fichier
        ttLong  : Integer;                          // Longueur des données envoyées
        ttDatas : Array[0..TailleBloc-1Of Byte )  // Données envoyées
  End;
//
//**************************************************************************************



//**************************************************************************************
//  SERVEUR
//  Cette partie ne concerne que le serveur
Var
  ServeurEnReception    : Boolean = False;     // =True quand une réception est en cours
  ServeurAdresseClient  : String  = '';        // Adresse du client connecté
  ServeurFichier        : File;                // Fichier utilisé pour la sauvegarde des morceaux


Procedure TForm1.btnOpenClick(Sender: TObject);
Begin
  // Bouton de mise en écoute du serveur, c'est tout simple
  Serveur.Open;
  MemoServeur.Lines.Add('Serveur en écoute');
End;

Procedure TForm1.btnCloseClick(Sender: TObject);
Begin
  // Bouton de fermeture du serveur, c'est aussi tout simple
  If     ServeurEnReception
     And (MessageDlg('Un transfert est en cours, fermer le serveur ?',mtConfirmation,[mbYes,mbNo],0)=mrYes)
  Then Begin
    Serveur.Close;
    MemoServeur.Lines.Add('Serveur desactivé');
  End;
End;

//
// évènements du socket serveur
//
Procedure TForm1.ServeurClientConnect(Sender: TObject;
  Socket: TCustomWinSocket);
Begin
  // C'est juste pour signaler
  MemoServeur.Lines.Add('OnConnect:'+Socket.RemoteAddress);
End;

Procedure TForm1.ServeurClientDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
Begin
  MemoServeur.Lines.Add('OnDisconnect:'+Socket.RemoteAddress);
  // Le client se deconnecte => ou ferme le fichier en cours si besoin
  If ServeurEnReception
  Then Begin
    CloseFile(ServeurFichier);
    ServeurEnReception:=False;
  End;
End;

Procedure TForm1.ServeurClientError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  Var ErrorCode: Integer);
Begin
  // On ne fait que signaler l'erreur
  MemoServeur.Lines.Add('OnClientError:'+Socket.RemoteAddress+#13+MessageErreurSocket(ErrorEvent,ErrorCode));
End;

Procedure TForm1.ServeurClientRead(Sender: TObject;
  Socket: TCustomWinSocket);
Var Buffer:TIPTrame;
    Erreur:Integer;
    Recus :Integer;
Begin
  // C'est ici la partie principale du serveur
  // Cette procédure est appelée à chaque écriture d'un client

  Erreur  :=0;
  Recus   :=Socket.ReceiveLength;    // Longueur reçue ( en octets )
  MemoServeur.Lines.Add('OnRead'+Socket.RemoteAddress+' reçus '+IntToStr(Recus));

  If Recus<= SizeOf(Buffer)         // On vérifie que la longueur reçue tient dans la trame
                                    // sinon attention au plantage !!!
  Then With Buffer Do Begin
    // Lecture de la trame reçue
    Socket.ReceiveBuf(Buffer,Recus);

    // En fonction du type de la trame on effectue les traitements
    Case ttType Of
      1:Begin
        // C'est une nouvelle demande, on vérifie le nom du fichier
        // La longueur de la trame doit être au minimumu de
        //   4 ( taille de ttType ) + 1 ( longueur de la chaine ttNomFichier ) + Length(ttNomFichier)
        If (Recus>=5)And(Recus>=(5+Length(ttNomFichier)))
        Then Begin
          // La longueur est bonne, on accepte la demande
          MemoServeur.Lines.Add(ttNomFichier);

          // On ferme le fichier précédent au cas ou
          If ServeurEnReception Then CloseFile(ServeurFichier);

          // On ouvre le fichier de réception en écriture
          AssignFile(ServeurFichier,ExtractFilePath(ParamStr(0))+ttNomFichier);
          Try
            Rewrite(ServeurFichier,1);
            ServeurEnReception:=True;
            Erreur:=0;
          Except
            Erreur:=5// Erreur de création du fichier
          End;
        End
        Else Erreur:=2// La longueur reçue est trop courte
      End;

      2:Begin
        // On reçoit un morceau de fichier
        // La longueur de la trame doit être au minimumu de
        //   4 ( taille de ttType ) + 4 ( taille de ttDebut ) + 4 ( taille de ttLong )
        //    + ttLong ( nombre de données envoyées )
        If (Recus>=12)And(Recus>=(12+ttLong))
        Then Begin
          // Le morceau n'est accepté que si une demande est en cours
          If ServeurEnReception
          Then Begin
            // Le morceau n'est accepté que si le début du fichier à déjà été reçu
            If (ttDebut>=0)And(ttDebut<=FileSize(ServeurFichier))
            Then Begin
              Try
                // Si tout est bon on écrit le morceau dans le fichier
                Seek(ServeurFichier,ttDebut);
                BlockWrite(ServeurFichier,ttDatas,ttLong);
                Erreur:=0;  // C'est bon
              Except
                Erreur:=6// Erreur d'écriture du fichier
              End;
            End
            Else Erreur:=4// La position 'début' n'est pas correcte
          End
          Else Erreur:=3// On n'a pas reçue de demande
        End
        Else Erreur:=2// La longueur reçue est trop courte
      End;

    End;// fin du case
  End
  Else Erreur:=1// La longueur reçue est trop grande

  // Dans tout les cas on envoie le code d'erreur au client
  Socket.SendBuf(Erreur,4);
  MemoServeur.Lines.Add('  Code de retour :'+IntToStr(Erreur));
End;
// fin de la partie serveur
//**************************************************************************************



//**************************************************************************************
//  CLIENT
//  Cette partie ne concerne que le client
Var
  ClientFichier   : File;       // Fichier en cours d'envoi
  ClientTrame     : TIPTrame;   // Copie de la dernière trame envoyée

Procedure TForm1.btnEnvoyerClick(Sender: TObject);
Begin
  // Bouton envoyer, c'est le début
  // On demande bien sur en premier le nom de fichier à transférer
  If Not Ouvrir.Execute Then Exit;
  AssignFile(ClientFichier,Ouvrir.FileName);

  // On ouvre le fichier en lecture
  Reset(ClientFichier,1);

  // On essaye de se connecter au serveur
  Client.Address:=Edit1.Text;
  Client.Open;
End;

Procedure TForm1.ClientConnect(Sender: TObject; Socket: TCustomWinSocket);
Begin
  // La connection est réussie
  MemoClient.Lines.Add('OnConnect:'+Socket.RemoteAddress);

  // On demande alors l'envoi de la trame d'entête
  ClientTrame.ttType:=1;
  ClientTrame.ttNomFichier:=ExtractFileName(Ouvrir.FileName);

  // La demande est différée par un petit timer car il est interdit
  // d'écrire dans un OnConnect
  btnEnvoyer.Enabled:=False;
  RetardDebut.Enabled:=True;
End;

Procedure TForm1.RetardDebutTimer(Sender: TObject);
Begin
  // Cette demande n'est faite qu'une fois par fichier
  RetardDebut.Enabled:=False;

  // On envoie au serveur la trame avec le nom du fichier
  Client.Socket.SendBuf(ClientTrame,4+Length(ClientTrame.ttNomFichier)+1);
  MemoClient.Lines.add('Envoi de l''entête');
End;

Procedure EnvoiBlocEnCours;
Begin
  With ClientTrame Do
  Begin
    // Procédure d'envoi d'un morceau de fichier
    // est appelée par ClientRead

    // C'est une trame de type morceau de fichier
    ttType:=2;

    // Lecture dans le fichier
    Seek(ClientFichier,ttDebut);
    BlockRead(ClientFichier,ttDatas,TailleBloc,ttLong);

    // Envoi du morceau
    // La longueur envoyée est
    //   4 ( taille de ttType ) + 4 ( taille de ttDebut ) + 4 ( taille de ttLong )
    //    + ttLong ( nombre de données envoyé )
    Form1.Client.Socket.SendBuf(ClientTrame,ttLong+12);
    Form1.MemoClient.Lines.add('Envoi du morceau '+IntToStr(ttDebut)+'['+IntToStr(ttLong)+']');
  End;
End;

Procedure TForm1.ClientRead(Sender: TObject; Socket: TCustomWinSocket);
Var CodeRetour:Integer;
Begin
  With ClientTrame Do
  Begin
    // On reçoit le code d'erreur du serveur, on le traite suivant les cas
    MemoClient.Lines.Add('OnRead:'+Socket.RemoteAddress);
    Socket.ReceiveBuf(CodeRetour,4);

    Case ttType Of
      1:Begin
          // La dernière demande était un nom de fichier
          // On teste le code de retour
          If CodeRetour=0
          Then Begin
            // Par d'erreur, l'envoi réel peut donc commencer
            ttDebut:=0;
            EnvoiBlocEnCours;
          End
          Else Begin
            // Le serveur refuse le fichier demandé => on arrète
            MemoClient.Lines.Add('Erreur '+IntToStr(CodeRetour));
            Client.Close;
          End;
        End;

      2:Begin
          // La dernière demande était un morceau de fichier
          // On teste le code de retour
          If CodeRetour=0
          Then Begin
            // Pas d'erreur on avance dans le fichier de la longueur envoyée précédemment
            Inc(ttDebut,ttLong);
            If ttDebut>=FileSize(ClientFichier)
              Then Client.Close        // C'est la fin du fichier, on ferme la connection
              Else EnvoiBlocEnCours;   // ce n'est pas la fin, on envoie le morceau
          End
          Else Begin
            // Une erreur à eut lieu, on envoie le même morceau
            MemoClient.Lines.Add('Erreur '+IntToStr(CodeRetour));
            EnvoiBlocEnCours;
          End;
        End;

      Else
        // Normalement on ne doit pas passer ici.
        // au cas ou, on ferme la connection
        Client.Close;
    End;
  End;
End;

Procedure TForm1.ClientDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
Begin
  // à la déconnection on ferme le fichier est cours de lecture
  MemoClient.Lines.Add('OnDisonnect:'+Socket.RemoteAddress);
  btnEnvoyer.Enabled:=True;
  CloseFile(ClientFichier);
End;

Procedure TForm1.ClientError(Sender: TObject; Socket: TCustomWinSocket;
  ErrorEvent: TErrorEvent; Var ErrorCode: Integer);
Begin
  // On ne fait que signaler l'erreur
  MemoServeur.Lines.Add('OnClientError:'+Socket.RemoteAddress+#13+MessageErreurSocket(ErrorEvent,ErrorCode));
End;

Procedure TForm1.btnStopClick(Sender: TObject);
Begin
  // Arrêt du transfert en cours
  RetardDebut.Enabled:=False;
  Client.Close;
End;
// fin de la partie client
//**************************************************************************************

End.

Les sources présentées sur cette page sont libres de droits et vous pouvez les utiliser à votre convenance. Par contre, la page de présentation constitue une œuvre intellectuelle protégée par les droits d'auteur. Copyright © 2003 Bruno Guérangé. Aucune reproduction, même partielle, ne peut être faite de ce site et de l'ensemble de son contenu : textes, documents, images, etc. sans l'autorisation expresse de l'auteur. Sinon vous encourez selon la loi jusqu'à trois ans de prison et jusqu'à 300 000 € de dommages et intérêts.

Responsables bénévoles de la rubrique Delphi : Gilles Vasseur - Alcatîz -