VBA et développement Web

Image non disponible


précédentsommairesuivant

X. API Winsock

Commençons par une petite traduction : l'élément de base de Winsock est la socket.
En anglais socket signifie prise de courant (celle qui est au mur) ou douille.
Ne pas confondre avec sock qui signifie chaussette.

Comme WinInet (chapitre précédent), Winsock est une librairie dont nous devons déclarer les fonctions, types et constantes utilisés.

Il est possible que vous ayez à votre disposition le contrôle ActiveX Winsock.
Celui est installé avec VB6 et avec certaines versions d'Office.
Pour l'utilisation de ce contrôle, je vous renvoie vers des tutoriels écrits pour VB6 mais dont le code est similaire en VBA :
- VB et les réseaux ;
- Winsock (client mail).

Dans la suite de cet article, nous allons utiliser l'API.

La liste des fonctions de cette API est sur MSDN en anglais : Winsock Reference.

Il existe deux librairies Winsock : wsock32.dll et ws2_32.dll.
ws2_32.dll est la version 2 de Winsock (qui permet également de cibler une version 1 de Winsock).
wsock32.dll est l'ancienne librairie conservée pour compatibilité.

X-A. Module VBA modWinsock

Nous allons avoir besoin de déclarer les fonctions, types et constantes de l'API.
De plus, il sera utile de créer quelques fonctions personnalisées pour effectuer des actions répétitives.

Créons donc un module VBA que nous appelons modWinSock.
Les fonctions utilisées dans les chapitres suivants seront ajoutées à ce module.

En fin de ce chapitre Winsock, vous trouverez le code de ce module.

X-B. Initialiser Winsock

Avant tout appel à une fonction Winsock, il est indispensable de lancer une fonction d'initialisation WSAStartup.
Si Winsock n'est plus utile, il faut appeler la fonction WSACleanup.

 
Sélectionnez

Public Declare Function WSAStartup Lib "ws2_32.dll" (ByVal wVersionRequested As Integer, ByRef lpWSAData As WSADATA) As Long
Public Declare Function WSACleanup Lib "ws2_32.dll" () As Long
            
Public Type WSADATA
 wVersion       As Integer
 wHighVersion   As Integer
 szDescription  As String * 256
 szSystemStatus As String * 128
 iMaxSockets    As Integer
 iMaxUdpDg      As Integer
 lpVendorInfo   As Long
End Type


WSAStartup accepte deux paramètres :
- wVersionRequested est la version minimale requise par le programme ;
- lpWSAData est une structure de type WSADATA qui reçoit des informations lors de l'initialisation.

En retour on obtient 0 si l'initialisation est correcte.

La version requise est un entier long créé ainsi :
Pour une version m.n :m + n * 256.

Pour cibler une version 1.1 (suffisante dans de nombreux cas) : 1 + 1 * 256 = 257.

Par exemple :

 
Sélectionnez

Function tuto1()
Dim lData As WSADATA
If WSAStartup(257, lData) = 0 Then
   ' le code suivant est à ajouter ici
   WSACleanup
End If
End Function


Cette fonction tuto1 est à écrire dans un nouveau module pour ne pas polluer le module modWinsock.

Après exécution de WSAStartup, la structure lData contient :
- une description szDescription : "WinSock 2.0" par exemple ;
- un statut szSystemStatus : "Running" par exemple ;
- la version demandée wVersion : 257 pour notre exemple ;
- la version maximale supportée wHighVersion : 514 par exemple.

Pour retrouver la version à partir d'un entier long :
- m = version mod 256
- n = version \ 256
Pour 514 => version 2.2.

En cas d'erreur WSAStartup renvoie un code d'erreur.
Pour les autres fonctions, il faut lire la valeur de Err.LastDllError.
Les codes d'erreur sont détaillés ici : Windows Sockets Error Codes.

X-C. Créer une socket

La socket est l'élément de base à toute connexion.
Pour la créer, nous utilisons la fonction socket.

déclaration de socket dans modWinsock
Sélectionnez

Public Declare Function socket Lib "ws2_32.dll" (ByVal AddressFamily As Long, ByVal SocketType As Long, ByVal Protocol As Long) As Long
Public Declare Function closesocket Lib "ws2_32.dll" (ByVal hSocket As Long) As Long
            
Public Const AF_INET = 2
Public Const SOCK_STREAM = 1


Deux constantes sont également utiles :
- AF_INET qui définit la famille d'adresse ;
- SOCK_STREAM qui définit le type de socket (TCP).

Ce type de socket est le plus simple et le plus courant : c'est le seul qu'on abordera dans cet article.
Pour plus d'information sur les familles d'adresses et types de sockets : socket Function.

On a également déclaré la fonction closesocket pour fermer la socket après utilisation.

Utilisons ces fonctions pour créer une socket :

création de socket
Sélectionnez

Function tuto1()
Dim lData As WSADATA
Dim lsock As Long
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
   ' Création d'une socket
   lsock = socket(AF_INET, SOCK_STREAM, 0)
   If lsock <> -1 Then
       ' le code suivant est à ajouter ici
       closesocket lsock
   End If
   WSACleanup
End If
End Function


La fonction socket renvoie un identifiant qu'il faut conserver pour utiliser la socket.
Si la création de fonctionne pas, la fonction renvoie -1 et il faut lire la valeur de Err.LastDllError pour connaître le code d'erreur.

closesocket ferme la socket une fois celle-ci devenue inutile.

X-D. Connecter une socket

Une socket peut être connectée à un serveur pourvu que celui-ci accepte des connexions .

Si vous êtes derrière un proxy, il faut vous connecter au proxy et non directement au serveur ciblé.
Pour une connexion FTP à travers un proxy, voir le chapitre Connexion à un serveur FTP.

Nous allons ici nous connecter à un serveur SMTP (serveur d'envoi de mail).
N'ayant pas de proxy SMTP à ma disposition, je n'ai pas pu tenter l'envoi de mail via un proxy SMTP.
La connexion est donc, dans cet exemple, directe sans proxy.

Utilisons par exemple le serveur SMTP de free.
Ce serveur est smtp.free.fr:25.

La fonction de connexion est Connect qui se déclare ainsi :

déclaration de Connect dans modWinsock
Sélectionnez

Public Declare Function Connect Lib "ws2_32.dll" Alias "connect" (ByVal hSocket As Long, ByRef Name As SOCKADDR, ByVal NameLen As Long) As Long
            
Private Type SOCKADDR
 sin_family As Integer
 sin_port(1 To 2) As Byte ' équivalent de u_short
 sin_addr   As Long       'structure IN_ADDR
 sin_zero   As String * 7
End Type


Cette fonction accepte trois paramètres :
- hSocket est l'identifiant de la socket créée avec la fonction socket ;
- Name est une structure de type SOCKADDR qui contient les informations de connexion ;
- NameLen est la taille de la structure SOCKADDR (à retrouver avec l'instruction LenB).

La structure SOCKADDR n'est pas si facile à renseigner :
- le premier élément sin_family est égal à AF_INET comme pour l'appel à la fonction socket ;
- le deuxième élément sin_port est le port ciblé (25) ; voir la suite pour le détail ;
- le troisième élément sin_addr est l'adresse du serveur ciblé (smtp.free.fr) ; voir la suite pour le détail ;
- le quatrième élément sin_zero est inutilisé.

Voici déjà le code sans le port et le serveur :

 
Sélectionnez

Function tuto1()
Dim lData As WSADATA
Dim lsock As Long
Dim lname As SOCKADDR
Dim lRet As Long
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
   ' Création d'une socket
   lsock = socket(AF_INET, SOCK_STREAM, 0)
   If lsock <> -1 Then
       lname.sin_family = AF_INET ' famille "classique"
       ' Ici on ajoutera le paramétrage du port et du serveur
       lRet = Connect(lsock, lname, LenB(lname))
       If lRet = 0 Then
           ' le code de dialogue avec la socket sera à ajouter ici
       End If
       closesocket lsock
   End If
   WSACleanup
End If
End Function


Le retour de la fonction connect renvoie 0 si la connexion est établie.

X-E. Le port sin_port

L'élément sin_port est un entier non signé (u_short en C).
Sa valeur est de 0 à 65535, stockée sur deux bytes.
On utilise habituellement la fonction htons de la librairie Winsock qui permet d'"inverser" ces deux bytes car les fonctions Winsock demandent un ordre de type "big endian".

déclaration de htons
Sélectionnez

Public Declare Function htons Lib "ws2_32.dll" (ByVal HostShort As Integer) As Integer



Par exemple la valeur 10000 est égale à 39 * 256 + 16 et est stockée ainsi : 16 39.
Pour Winsock il faut inverser et stocker le nombre ainsi : 39 16.
Donc 16 * 256 + 39 = 4135.

La fonction htons nous renvoie bien 4135.

Un problème survient si on souhaite utiliser le port 50000 par exemple. La fonction htons renvoie une erreur en VBA car 50000 dépasse la capacité d'un Integer.
En VBA nous n'avons pas d'entier non signé : Integer est un entier signé dont la valeur est comprise entre -32 768 et 32 767.

C'est pour cela que j'ai déclaré sin_port en tableau de deux bytes.
Il nous suffit de calculer nous-mêmes les deux bytes :
- la première valeur : 50000 \ 256 = 195
- la deuxième valeur : 50000 mod 256 = 80

On calcule pour information : 80 * 256 + 195 = 20675.
20675 est la valeur que nous aurait renvoyé htons si on avait un entier non signé à notre disposition dans VBA.

Voici donc le paramétrage du port 25 :

 
Sélectionnez

[...]
   If lsock <> -1 Then
       lname.sin_family = AF_INET ' famille "classique"
       lname.sin_port(1) = 25 \ 256 ' première partie du port
       lname.sin_port(2) = 25 Mod 256 ' deuxième partie du port
[...]

Il est cependant tout à fait possible d'utiliser la fonction htons pour des ports compris entre 0 et 32 767 (avec sin_port de type Integer dans le type SOCKADDR).

X-F. Le serveur sin_addr

Voici un paramètre bien compliqué.
sin_addr est un entier long, alors que l'adresse de notre hôte est une chaîne de caractères (stmp.free.fr).

Voici les déclarations dont nous avons besoin :

déclarations pour sin_addr à ajouter au module modWinsock
Sélectionnez

Public Declare Function gethostbyname Lib "ws2_32.dll" (ByVal Name As String) As Long
Public Declare Function inet_addr Lib "ws2_32.dll" (ByVal IpAddress As String) As Long
Public Declare Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, Source As Any, ByVal length As Long)
            
Public Type HOSTENT
 hName     As Long
 hAliases  As Long
 hAddrType As Integer
 hLength   As Integer
 hAddrList As Long
End Type


- gethostbyname permet de trouver l'adresse IP d'un serveur à partir de son nom (à travers la structure HOSTENT).
- inet_addr permet de transformer l'adresse IP en un entier long.
- RtlMoveMemory est une fonction de l'API Windows qui nous permet de déplacer des zones de mémoire.

Dans le module modWinsock, nous créons une fonction qui permet de transformer le nom du serveur en une adresse dans un entier long pour l'élément sin_addr :
cette fonction doit être écrite après toutes les déclarations du module.


fonction addrfromhost à ajouter au module modWinsock
Sélectionnez

' -------------------------------------------------------------
' Donnez un nom de serveur en entrée: par exemple smtp.free.fr
' Retourne un entier long pour utilisation dans sin_addr
' WSAStartup doit être exécuté avant cette fonction
' -------------------------------------------------------------
Public Function addrfromhost(host As String) As Long
Dim lHostEnt As HOSTENT
Dim lHost As Long
Dim lAddress() As Byte
Dim lHostAddress As Long
   ' lhost est un pointeur vers une structure HOSTENT
   lHost = gethostbyname(host)
   If lHost <> 0 Then
       ' Déplace le contenu mémoire à l'emplacement du pointeur lHost vers la structure lHostEnt
       RtlMoveMemory lHostEnt, ByVal lHost, LenB(lHostEnt)
       ' Prépare un tableau contenant les 4 parties de l'adresse
       ReDim lAddress(1 To lHostEnt.hLength) As Byte
       ' Récupère le pointeur de l'adresse dans lHostAddress
       ' hAddrList est un pointeur vers un pointeur
       RtlMoveMemory lHostAddress, ByVal lHostEnt.hAddrList, lHostEnt.hLength
       ' Déplace l'adresse dans le tableau lAddress
       RtlMoveMemory lAddress(1), ByVal lHostAddress, lHostEnt.hLength
       ' Transforme l'adresse (ex&#160;: 212.29.48.4) en entier long avec inet_addr
       '  et retourne cette valeur
       addrfromhost = inet_addr(lAddress(1) & "." & lAddress(2) & "." & lAddress(3) & "." & lAddress(4))
   End If
End Function


Il suffit ensuite d'utiliser cette fonction pour remplir l'élément sin_addr :

 
Sélectionnez

[...]
   If lsock <> -1 Then
       lname.sin_family = AF_INET ' famille "classique"
       lname.sin_port(1) = 25 \ 256 ' première partie du port
       lname.sin_port(2) = 25 Mod 256 ' deuxième partie du port
       lname.sin_addr = addrfromhost("smtp.free.fr") ' adresse du serveur
[...]

X-G. Récapitulatif


Voici le code complet de connexion, à utiliser avec le module modWinsock qui contient les déclarations :

 
Sélectionnez

Function tuto1()
Dim lData As WSADATA
Dim lsock As Long
Dim lname As SOCKADDR
Dim lRet As Long
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
   ' Création d'une socket
   lsock = socket(AF_INET, SOCK_STREAM, 0)
   If lsock <> -1 Then
       lname.sin_family = AF_INET ' famille "classique"
       lname.sin_port(1) = 25 \ 256 ' première partie du port
       lname.sin_port(2) = 25 Mod 256 ' deuxième partie du port
       lname.sin_addr = addrfromhost("smtp.free.fr") ' adresse du serveur
       ' Connexion
       lRet = Connect(lsock, lname, LenB(lname))
       If lRet = 0 Then
           ' le code de dialogue avec la socket sera à ajouter ici
           MsgBox "connecté!" ' Boîte de dialogue pour test
       End If
       closesocket lsock
   End If
   WSACleanup
End If
End Function


Si le retour de la fonction Connect est 0, la socket est bien connectée au serveur.
Sinon, il faut regarder la valeur de Err.LastDllError pour connaître le code d'erreur.

Par exemple, une tentative de connexion sur le port 26 lève une erreur 10061 : Connexion refusée.

X-H. Recevoir des données

Nous avons envoyé une demande de connexion au serveur, il s'agit maintenant de lire sa réponse.
C'est la fonction recv qui se charge de la lecture.

déclaration de recv dans modWinsock
Sélectionnez

Public Declare Function recv Lib "ws2_32.dll" (ByVal hSocket As Long, ByRef buffer As Any, ByVal BufferLength As Long, ByVal Flags As Long) As Long
Public Declare Function recvstr Lib "ws2_32.dll" Alias "recv" (ByVal hSocket As Long, ByVal buffer As String, ByVal BufferLength As Long, ByVal Flags As Long) As Long


La fonction recv accepte quatre paramètres :
- hSocket est l'identifiant de la socket ;
- buffer contiendra les données reçues, il doit être dimensionné de la taille de BufferLength au minimum ;
- BufferLength est la taille des données à recevoir ;
- Flags est un paramètre que nous n'utiliserons pas.

Nous ne connaissons pas par avance la taille des données à recevoir.
Pour faire simple, nous allons d'abord nous contenter de lire 1024 caractères, ce qui sera suffisant pour cette première lecture.

Notez que nous avons déclaré une fonction srecvstr qui est un appel à la fonction recv mais avec un type de paramètre différent pour le buffer.
Cette fonction sera utile pour recevoir facilement des chaînes de caractères.
La réception de chaînes de caractères (String) avec la fonction recv nécessiterait une conversion des données avec StrConv.

réception de données
Sélectionnez

[...]
       ' Connexion
       lRet = Connect(lsock, lname, LenB(lname))
       If lRet = 0 Then
           ' Réception des données de connexion
           lStrToReceive = Space(1024)
           lRet = recvstr(lsock, lStrToReceive, Len(lStrToReceive), 0)
           If lRet > 0 Then
               lStrToReceive = Left(lStrToReceive, lRet)
               Debug.Print "Octets reçus : " & lRet & vbCrLf & lStrToReceive
           End If
[...]


Pour recevoir des données, on remplit d'abord une variable lStrToReceive par des espaces.
La fonction retourne la taille des données lues, ce qui permet de tronquer la variable à la bonne taille.

Voici le résultat obtenu :

Octets reçus : 37
220 smtp1-g21.free.fr ESMTP Postfix



À noter :
- la fonction de réception est synchrone : c'est-à-dire que l'exécution est interrompue tant que des données ne sont pas reçues ;
- il est utile de vérifier au préalable si le serveur a envoyé des données, sinon on risque de bloquer l'exécution ;
- il est également utile de vérifier que toutes les données ont été lues.

Nous tiendrons compte de ces dernières remarques dans le chapitre suivant sur l'envoi/réception avec timeout.

X-I. Envoyer des données

Une fois connecté, on souhaite envoyer (et recevoir) des données.

Comme nous sommes connectés à un serveur SMTP, nous allons envoyer une commande EHLO qui est la première commande à exécuter pour ce type de serveur.

L'envoi de données se fait à l'aide de la fonction send.

déclaration de send dans modWinsock
Sélectionnez

Public Declare Function send Lib "ws2_32.dll" (ByVal hSocket As Long, ByRef buffer As Any, _
                                              ByVal BufferLength As Long, ByVal Flags As Long) As Long
Public Declare Function sendstr Lib "ws2_32.dll" Alias "send" (ByVal hSocket As Long, _
                         ByVal buffer As String, ByVal BufferLength As Long, ByVal Flags As Long) As Long


La fonction send accepte quatre paramètres :
- hSocket est l'identifiant de la socket ;
- buffer contient les données à envoyer ;
- BufferLength est la taille des données à envoyer ;
- Flags est un paramètre que nous n'utiliserons pas.

Elle retourne le nombre de caractères effectivement envoyés.
En cas d'erreur d'envoi, la fonction retourne -1.

Il est possible que les données ne soient pas entièrement envoyées en une fois.
Il faut alors envoyer le reste des données jusqu'à ce que tout soit envoyé.


Notez que nous avons déclaré une fonction sendstr qui est un appel à la fonction send mais avec un type de paramètre différent pour le buffer.
Cette fonction sera utile pour envoyer facilement des chaînes de caractères.
L'envoi de chaînes de caractères (String) avec la fonction send nécessiterait une conversion des données avec StrConv.

Une fois la commande envoyée, nous lisons ensuite la réponse du serveur.

Envoi de commande EHLO
Sélectionnez

[...]
       ' Connexion
       lRet = Connect(lsock, lname, LenB(lname))
       If lRet = 0 Then
           ' Envoi d'une commande EHLO
           lStrToSend = "EHLO smtp.free.fr" & vbCrLf
           ' Envoi des données
           lRet = sendstr(lsock, lStrToSend, Len(lStrToSend), 0)
           Debug.Print "Octets envoyés : " & lRet & " / " & Len(lStrToSend)
           ' Réception des données
           lStrToReceive = Space(1024)
           lRet = recvstr(lsock, lStrToReceive, Len(lStrToReceive), 0)
           If lRet > 0 Then
               lStrToReceive = Left(lStrToReceive, lRet)
               Debug.Print "Octets reçus : " & lRet & vbCrLf & lStrToReceive
           End If
       Else
           Debug.Print "Erreur de connexion  " & Err.LastDllError
       End If
[...]

Le VbCrLf en fin de commande est un saut de ligne indispensable pour demander l'exécution de la commande.


Si tout se passe bien, lRet doit contenir 19 qui est la taille des données envoyées.

À noter :
- la fonction d'envoi est synchrone : c'est-à-dire que l'exécution est interrompue tant que les données ne sont pas envoyées ;
- il est utile de vérifier avant envoi si le serveur est prêt à recevoir des données, sinon on risque de bloquer l'exécution ;
- il est également utile de vérifier que toutes les données ont été envoyées.

Nous tiendrons compte de ces dernières remarques dans le chapitre suivant sur l'envoi/réception avec timeout.

Voici le code complet d'envoi/réception de données, à utiliser avec le module modWinsock qui contient les déclarations :

 
Sélectionnez

Function tuto1()
Dim lData As WSADATA
Dim lsock As Long
Dim lname As SOCKADDR
Dim lRet As Long
Dim lStrToSend As String
Dim lStrToReceive As String
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
   ' Création d'une socket
   lsock = socket(AF_INET, SOCK_STREAM, 0)
   If lsock <> -1 Then
       lname.sin_family = AF_INET ' famille "classique"
       lname.sin_port(1) = 25 \ 256 ' première partie du port
       lname.sin_port(2) = 25 Mod 256 ' deuxième partie du port
       lname.sin_addr = addrfromhost("smtp.free.fr") ' adresse du serveur
       ' Connexion
       lRet = Connect(lsock, lname, LenB(lname))
       If lRet = 0 Then
           ' Réception des données de connexion
           lStrToReceive = Space(1024)
           lRet = recvstr(lsock, lStrToReceive, Len(lStrToReceive), 0)
           If lRet > 0 Then
               lStrToReceive = Left(lStrToReceive, lRet)
               Debug.Print "Octets reçus : " & lRet & vbCrLf & lStrToReceive
           End If
           ' Envoi d'une commande EHLO
           lStrToSend = "EHLO smtp.free.fr" & vbCrLf
           ' Envoi des données
           lRet = sendstr(lsock, lStrToSend, Len(lStrToSend), 0)
           Debug.Print "Octets envoyés : " & lRet & " / " & Len(lStrToSend)
           ' Réception des données
           lStrToReceive = Space(1024)
           lRet = recvstr(lsock, lStrToReceive, Len(lStrToReceive), 0)
           If lRet > 0 Then
               lStrToReceive = Left(lStrToReceive, lRet)
               Debug.Print "Octets reçus : " & lRet & vbCrLf & lStrToReceive
           End If
       Else
           MsgBox "Erreur de connexion  " & Err.LastDllError
       End If
       closesocket lsock
   End If
   WSACleanup
End If
End Function


Si vous exécutez ce code derrière un proxy, vous obtiendrez certainement une erreur (dans mon cas : erreur 10054 sur réception de données).

Sinon, voici le résultat obtenu :

Octets reçus : 37
220 smtp1-g21.free.fr ESMTP Postfix

Octets envoyés : 19 / 19
Octets reçus : 126
250-smtp1-g21.free.fr
250-PIPELINING
250-SIZE 35000000
250-VRFY
250-ETRN
250-ENHANCEDSTATUSCODES
250-8BITMIME
250 DSN


Ceci est le texte renvoyé par le serveur.

X-J. Envoyer et recevoir des données avec Timeout

Dans les deux chapitres précédents nous avons envoyé et reçu des données de manière simple.
Pour couvrir tous les cas possibles, il est utile de créer des fonctions d'envoi et de réception qui font quelques vérifications et s'assurent que les données ont bien été envoyées ou reçues en totalité.
De plus, programmer un timeout est presque indispensable pour ne pas se retrouver bloqué en attente d'envoi ou de réception.

La fonction qui nous permet de vérifier si la socket est prête à envoyer ou recevoir est la fonction select :

déclaration de select dans modWinsock
Sélectionnez

Public Declare Function wselect Lib "ws2_32.dll" Alias "select" (ByVal Reserved As Long, _
                                        ByRef ReadFds As FD_SET, ByRef WriteFds As FD_SET, _
                                        ByRef ExceptFds As FD_SET, ByRef timeout As TIMEVAL) As Long
            
Public Type FD_SET
 fd_count     As Long
 fd_array(1 To 64) As Long
End Type
            
Public Type TIMEVAL
 tv_sec  As Long
 tv_usec As Long
End Type


select étant un mot-clé réservé de VBA, j'ai appelé la fonction wselect.

Les types FD_SET et TIMEVAL sont utilisés par cette fonction.

On a cinq paramètres en entrée :
- Reserved est inutilisé ;
- ReadFds est une structure de type FD_SET définissant les sockets à vérifier pour lecture (=réception) ;
- WriteFds est une structure de type FD_SET définissant les sockets à vérifier pour écriture (=envoi) ;
- ExceptFds est une structure de type FD_SET définissant les sockets à vérifier pour statut en erreur ;
- timeout est une structure de type TIMEVAL définissant le timeout.

Chaque structure FD_SET doit être remplie ainsi :
- fd_count est le nombre de sockets à vérifier ;
- fd_array est un tableau d'identifiant de socket.

La structure TIMEVAL doit être remplie ainsi :
- tv_sec est un temps en secondes ;
- tv_usec est un temps en microsecondes ;
Ces deux temps sont cumulés.

La fonction renvoie le nombre de sockets prêtes.
Si le temps défini est écoulé, la fonction renvoie 0.
S'il y a une erreur, la fonction renvoie -1.

Voici deux fonctions pour envoyer et recevoir des données de type String avec un délai en secondes (10 par défaut) :

fonctions d'envoi et réception dans modWinsock
Sélectionnez
' -----------------------------------------------------------------------------
' Réception de données (String) sur une socket sock avec timeout en secondes
' Si retour = -1 => erreur
' -----------------------------------------------------------------------------
Public Function RecvStrTO(sock, Optional timeout As Long = 10) As String
Dim lBuffer As String
Dim lfdr As FD_SET, lfdw As FD_SET, lfde As FD_SET
Dim lret As Long
Dim lti As TIMEVAL
' délai en secondes
lti.tv_sec = timeout
' une socket à vérifier
lfdr.fd_count = 1
' la socket passée en paramètre
lfdr.fd_array(1) = sock
' la socket est-elle prête?
lret = wselect(0, lfdr, lfdw, lfde, lti)
' Si pas d'erreur et délai non dépassé
If lret > 0 Then
    ' Boucle tant qu'il y a des données
    Do
        ' Si socket prête
        If lfdr.fd_count = 1 Then
            ' Réception
            lBuffer = Space(1024)
            lret = recvstr(sock, lBuffer, 1024, 0)
            ' Ajoute les données reçues au résultat
            If lret > 0 Then
                lBuffer = Left(lBuffer, lret)
                RecvStrTO = RecvStrTO & lBuffer
            ElseIf lret = 0 Then
                Exit Do
            ElseIf lret < 0 Then
                RecvStrTO = "-1"
                Exit Do
            End If
        End If
        ' Vérifie s'il y a encore des données à recevoir (avec délai à 1 usec)
        lfdr.fd_count = 1
        lti.tv_sec = 0
        lti.tv_usec = 1
        lret = wselect(0, lfdr, lfdw, lfde, lti)
        If lret <= 0 Then
               Exit Do
        End If
    Loop
End If
End Function
' -----------------------------------------------------------------------------
' Envoi de données (String) sur une socket sock avec timeout en secondes
' Cette fonction renvoit True si l'envoi est correct
' -----------------------------------------------------------------------------
Public Function SendStrTO(sock, ByVal StrToSend As String, Optional timeout As Long = 10) As Boolean
Dim lBuffer As String
Dim lfdr As FD_SET, lfdw As FD_SET, lfde As FD_SET
Dim lret As Long
Dim lti As TIMEVAL
' délai en secondes
lti.tv_sec = timeout
' une socket à vérifier
lfdw.fd_count = 1
' la socket passée en paramètre
lfdw.fd_array(1) = sock
' la socket est-elle prête?
lret = wselect(0, lfdr, lfdw, lfde, lti)
' Si pas d'erreur et délai non dépassé
If lret > 0 Then
    ' Boucle tant qu'il y a des données à envoyer
    Do
        ' Si socket prête
        If lfdw.fd_count = 1 Then
            ' Envoi
            lret = sendstr(sock, StrToSend, Len(StrToSend), 0)
            ' Test le retour
            If lret = -1 Then
                ' Erreur
                SendStrTO = False
                Exit Do
            Else
                If lret < Len(StrToSend) Then
                    ' Envoi partiel
                    StrToSend = Mid(StrToSend, lret + 1)
                Else
                    ' Envoi terminé
                    SendStrTO = True
                    Exit Do
                End If
            End If
        End If
    Loop
End If
End Function            


Et la fonction du tutoriel modifiée pour utiliser ces deux nouvelles fonctions :

 
Sélectionnez

Function tuto1()
Dim lData As WSADATA
Dim lsock As Long
Dim lname As SOCKADDR
Dim lRet As Long
Dim lStrToSend As String
Dim lStrToReceive As String
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
   ' Création d'une socket
   lsock = socket(AF_INET, SOCK_STREAM, 0)
   If lsock <> -1 Then
       lname.sin_family = AF_INET ' famille "classique"
       lname.sin_port(1) = 25 \ 256 ' première partie du port
       lname.sin_port(2) = 25 Mod 256 ' deuxième partie du port
       lname.sin_addr = addrfromhost("smtp.free.fr") ' adresse du serveur
       ' Connexion
       lRet = Connect(lsock, lname, LenB(lname))
       If lRet = 0 Then
           ' Envoi d'une commande EHLO
           lStrToSend = "EHLO smtp.free.fr" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée&#160;: " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reçus&#160;: " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
       Else
           Debug.Print "Erreur de connexion  " & Err.LastDllError
       End If
       closesocket lsock
   End If
   WSACleanup
End If
End Function


Ces deux fonctions vont nous être utiles pour la suite.

X-K. Envoyer des mails par SMTP

L'envoi de mail se fait à l'aide d'envoi de commandes successives.
Pour savoir quelles commandes il faut envoyer, vous pouvez chercher sur internet par exemple avec les mots-clés SMTP Telnet.

X-K-1. Mail Free (sans authentification)

Voici un exemple d'envoi de mail :

Envoi de mail avec free
Sélectionnez

Function tuto_mail_free()
Dim lData As WSADATA
Dim lsock As Long
Dim lname As SOCKADDR
Dim lRet As Long
Dim lStrToSend As String
Dim lStrToReceive As String
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
   ' Création d'une socket
   lsock = socket(AF_INET, SOCK_STREAM, 0)
   If lsock <> -1 Then
       lname.sin_family = AF_INET ' famille "classique"
       lname.sin_port(1) = 25 \ 256 ' première partie du port
       lname.sin_port(2) = 25 Mod 256 ' deuxième partie du port
       lname.sin_addr = addrfromhost("smtp.free.fr") ' adresse du serveur
       ' Connexion
       lRet = Connect(lsock, lname, LenB(lname))
       If lRet = 0 Then
           ' Réception des données de connexion
           lStrToReceive = RecvStrTO(lsock)
           Debug.Print "Octets reçus&#160;: " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           ' Envoi d'une commande EHLO
           lStrToSend = "EHLO smtp.free.fr" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée&#160;: " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Envoi du mail source
           lStrToSend = "MAIL FROM: <monmail.source@free.fr>" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée&#160;: " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reçus&#160;: " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Envoi du mail cible
           lStrToSend = "RCPT TO: <monmail.cible@hotmail.fr>" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée&#160;: " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Début des données
           lStrToSend = "DATA" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Objet du mail
           lStrToSend = "SUBJECT: Test Tuto DVP Winsock" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Contenu du mail
           lStrToSend = "Contenu du mail." & vbCrLf & "Utilisez vbCrLf pour passer à la ligne" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Fin du contenu => déclenche l'envoi du mail
           lStrToSend = "." & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Quitte le serveur
           lStrToSend = "quit" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
       Else
           Debug.Print "Erreur de connexion  " & Err.LastDllError
       End If
       closesocket lsock
   End If
   WSACleanup
End If
End Function


Remarque : pour marquer la fin du contenu du mail et déclencher l'envoi, il faut envoyer un point suivi d'un retour à la ligne.

Voici le résultat obtenu dans la fenêtre Exécution :

Octets reçus : 37 220 smtp1-g21.free.fr ESMTP Postfix Commande envoyée : EHLO smtp.free.fr Octets reçus : 126 250-smtp1-g21.free.fr 250-PIPELINING 250-SIZE 35000000 250-VRFY 250-ETRN 250-ENHANCEDSTATUSCODES 250-8BITMIME 250 DSN Commande envoyée : MAIL FROM: <monmail.source@free.fr> Octets reçus : 14 250 2.1.0 Ok Commande envoyée : RCPT TO: <monmail.cible@hotmail.fr> Octets reçus : 14 250 2.1.5 Ok Commande envoyée : DATA Octets reçus : 37 354 End data with <CR><LF>.<CR><LF> Commande envoyée : SUBJECT: Test Tuto DVP Winsock Octets reçus : 0 Commande envoyée : Contenu du mail. Utilisez vbCrLf pour passer à la ligne Octets reçus : 0 Commande envoyée : . Octets reçus : 37 250 2.0.0 Ok: queued as 5F97D940072 Commande envoyée : quit Octets reçus : 15 221 2.0.0 Bye

On peut bien sûr exploiter les données reçues pour lire les codes retour et réagir en cas d'erreur.

Notez que certaines commandes (celles qui envoient les données du mail, après la commande DATA) ne donnent pas lieu à une réponse du serveur.
On peut retirer les lectures d'information inutiles qui ralentissent le traitement en attente du timeout.

Notez également que sur le mail reçu, l'accent n'est pas correctement restitué.

Il est possible d'envoyer, avant le contenu du mail, le codage à utiliser :

 
Sélectionnez

           ' En-tête des données
           lStrToSend = "Content-Type: text/plain; charset=""iso-8859-1""" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
           End If


On définit ici un contenu texte brut (text/plain) avec un codage (charset) iso-8859-1.
Les accents sont alors correctement restitués.

Les valeurs possibles de la valeur de Content-Type sont listées ici : MIME Media Types.

Il est par exemple possible d'envoyer un contenu de mail en HTML en précisant un type text/HTML :

 
Sélectionnez

            [...]
           ' En-tête des données
           lStrToSend = "Content-Type: text/HTML; charset=""iso-8859-1""" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
           End If
           ' Contenu du mail
           lStrToSend = "<b>Contenu du mail.</b>" & "<br/>" & "<i>Utilisez <br/> pour passer à la ligne</i>" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
           End If
           [...]

Le serveur SMTP de free ne demande pas d'authentification.
On peut donc l'utiliser sans même avoir de compte chez free.

X-K-2. Mail Hotmail (avec authentification)

Le serveur hotmail est smtp.live.com sur le port 587.
Ce serveur demande une authentification : il faut donc un Windows Live ID (compte Hotmail ou Messenger) pour l'utiliser.

Les informations de connexion doivent être codées en Base64.
Nous allons créer une fonction de codage en Base64 grâce à la librairie crypt32.dll apparue avec Windows XP.

déclaration des fonctions de crypt32.dll dans modWinsock
Sélectionnez

Public Declare Function CryptBinaryToString Lib "crypt32.dll" Alias "CryptBinaryToStringA" _
                        (ByVal pbBinary As String, ByVal cbBinary As Long, ByVal dwFlags As Long, _
                         ByVal pszString As String, ByRef pcchString As Long) As Long
            
Public Const CRYPT_STRING_BASE64 = 1
fonctions de codage dans modWinsock
Sélectionnez

' -----------------------------------------------------------------------------
' Codage Base64
' -----------------------------------------------------------------------------
Public Function Base64(ByVal pStr As String) As String
 Dim lStrReturn As String
 Dim lStrLen As Long
 ' Récupère la taille nécessaire
 Call CryptBinaryToString(pStr, Len(pStr), CRYPT_STRING_BASE64, vbNullString, lStrLen)
 If (lStrLen > 0) Then
     lStrReturn = Space$(lStrLen - 1) ' on retire le chr(0) final
     ' Code en Base64
     Call CryptBinaryToString(pStr, Len(pStr), CRYPT_STRING_BASE64, lStrReturn, lStrLen - 1)
 End If
 Base64 = lStrReturn
End Function

Base64 est un codage et non un cryptage.
Ce n'est nullement une sécurisation des informations.

Le codage en Base64 avec la fonction CryptBinaryToString ajoute automatiquement un saut de ligne (vbCrLf) en fin de chaîne.
Il ne faut donc pas en ajouter un second lors de l'envoi de la commande.


Voici un exemple d'envoi de mail avec Hotmail :

Envoi de mail avec hotmail
Sélectionnez

Function tuto_mail_hotmail()
Dim lData As WSADATA
Dim lsock As Long
Dim lname As SOCKADDR
Dim lRet As Long
Dim lStrToSend As String
Dim lStrToReceive As String
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
   ' Création d'une socket
   lsock = socket(AF_INET, SOCK_STREAM, 0)
   If lsock <> -1 Then
       lname.sin_family = AF_INET ' famille "classique"
       lname.sin_port(1) = 587 \ 256 ' première partie du port
       lname.sin_port(2) = 587 Mod 256 ' deuxième partie du port
       lname.sin_addr = addrfromhost("smtp.live.com") ' adresse du serveur
       ' Connexion
       lRet = Connect(lsock, lname, LenB(lname))
       If lRet = 0 Then
           ' Réception des données de  Connexion
           lStrToReceive = RecvStrTO(lsock)
           Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           ' Envoi d'une commande EHLO
           lStrToSend = "EHLO smtp.live.com" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Envoi d'une commande d'authentification
           lStrToSend = "AUTH LOGIN" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Envoi de l'ID = login
           lStrToSend = Base64("monmail@hotmail.fr")
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Envoi du mot de passe
           lStrToSend = Base64("MonMotDePasse")
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Envoi du mail source
           lStrToSend = "MAIL FROM: <monmail.source@hotmail.fr>" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsoc)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Envoi du mail cible
           lStrToSend = "RCPT TO: <monmail.cible@free.fr>" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Début des données
           lStrToSend = "DATA" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Objet du mail
           lStrToSend = "SUBJECT: Test Tuto DVP Winsock" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
           End If
           ' Contenu du mail
           lStrToSend = "Contenu du mail." & vbCrLf & "Utilisez vbCrLf pour la ligne suivante" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
           End If
           ' Fin du contenu => déclenche l'envoi du mail
           lStrToSend = "." & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Quitte le serveur
           lStrToSend = "quit" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
       Else
           Debug.Print "Erreur de connexion  " & Err.LastDllError
       End If
       closesocket lsock
   End If
   WSACleanup
End If
End Function

X-K-3. Envoi de pièces jointes

L'envoi de pièce jointe se fait avec un format très précis.
Le contenu du mail doit être écrit dans un élément multipart/mixed.
La construction des données ressemble fortement à ce qu'on a vu dans le chapitre Passage de paramètres multiples complexes.

Une pièce jointe s'envoie généralement en codage base64 (comme pour l'authentification SMTP avec AUTH LOGIN).

Voici un exemple d'envoi de fichier texte joint :

 
Sélectionnez

Function tuto_mail_hotmail_avec_piece_jointe()
Dim lData As WSADATA
Dim lsock As Long
Dim lname As SOCKADDR
Dim lret As Long
Dim lStrToSend As String
Dim lStrToReceive As String
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
   ' Création d'une socket
   lsock = socket(AF_INET, SOCK_STREAM, 0)
   If lsock <> -1 Then
       lname.sin_family = AF_INET ' famille "classique"
       lname.sin_port(1) = 587 \ 256 ' première partie du port
       lname.sin_port(2) = 587 Mod 256 ' deuxième partie du port
       lname.sin_addr = addrfromhost("smtp.live.com") ' adresse du serveur
       ' Connexion
       lret = Connect(lsock, lname, LenB(lname))
       If lret = 0 Then
           ' Réception des données de connexion
           lStrToReceive = RecvStrTO(lsock)
           Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           ' Envoi d'une commande EHLO
           lStrToSend = "EHLO smtp.live.com" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Envoi d'une commande d'authentification
           lStrToSend = "AUTH LOGIN" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Envoi de l'ID = login
           lStrToSend = Base64("monID@hotmail.fr")
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Envoi du mot de passe
           lStrToSend = Base64("monMotDePasse")
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Envoi du mail source
           lStrToSend = "MAIL FROM: <monmail.source@hotmail.fr>" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Envoi du mail cible
           lStrToSend = "RCPT TO: <monmail.cible@free.fr>" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Début des données
           lStrToSend = "DATA" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Objet du mail
           lStrToSend = "SUBJECT: Test Tuto DVP Winsock" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
           End If
           ' Contenu du mail
           lStrToSend = "MIME-Version: 1.0" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
           End If
           lStrToSend = "Content-type: multipart/mixed;boundary=""ax0rt1232"")" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
           End If
           lStrToSend = vbCrLf & "--ax0rt1232" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
           End If
           lStrToSend = "Content-type: text/plain" & vbCrLf & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
           End If
           lStrToSend = "Contenu du mail." & vbCrLf & "Utilisez vbCrLf pour passer a la ligne" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
           End If
           lStrToSend = "--ax0rt1232" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
           End If
           lStrToSend = "Content-Type: application/text; name=""myfile.txt""" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
           End If
           lStrToSend = "Content-Transfer-Encoding: base64" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
           End If
           lStrToSend = "Content-Disposition: attachment; filename=""myfile.txt""" & vbCrLf & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
           End If
           lStrToSend = Base64("Contenu du fichier")
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
           End If
           lStrToSend = "--ax0rt1232--" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
           End If
           ' Fin du contenu => déclenche l'envoi du mail
           lStrToSend = "." & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Quitte le serveur
           lStrToSend = "quit" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
       Else
           Debug.Print "Erreur de connexion  " & Err.LastDllError
       End If
       closesocket lsock
   End If
   WSACleanup
End If
End Function

X-L. Gestion d'un serveur FTP

Un autre serveur bien connu est le serveur FTP.
Les sockets vont nous permettre de réaliser (au prix de quelques efforts) toutes les opérations habituelles d'un client FTP.
On pourra même se connecter à travers un proxy.

Afin de tester le serveur et visualiser les commandes utiles, je vous conseille d'installer FileZilla, un client FTP gratuit.


La connexion à un serveur FTP se fait différemment en fonction du type de proxy éventuellement utilisé.
Un lien (en anglais) sur le sujet : How Proxy Server serves FTP clients?

On peut également se connecter avec FileZilla et voir les commandes envoyées.

Ce qu'il faut bien retenir :
- si la connexion est directe : on connecte la socket au serveur FTP directement.
- si la connexion passe par un proxy : on connecte la socket au proxy qui se chargera de communiquer avec le serveur FTP.

Nous utiliserons le module modWinsock du chapitre précédent.

Mais attention : le serveur FTP peut envoyer des données en plusieurs fois.
La norme FTP défini que l'envoi est terminé lorsqu'on reçoit une ligne avec un code (3 chiffres) suivi d'un espace.

Afin d'éviter un décalage entre les envois et réceptions de message, nous allons ajouter une nouvelle fonction qui va lire en boucle les messages du serveur jusqu'à recevoir le code de fin d'envoi (3 chiffres + un espace).

Voici cette fonction RecvStrTOFTP :

 
Sélectionnez
' -----------------------------------------------------------------------------
' Réception de données (String) depuis FTP (attente d'un code suivi d'un espace)
' Cf. RFC 959, section 4.2
' -----------------------------------------------------------------------------
Public Function RecvStrTOFTP(sock, Optional timeout As Long = 15) As String
Dim lBuffer As String
Dim lPos As Long
Dim lcpt As Long
Do
    lcpt = lcpt + 1
    lBuffer = RecvStrTO(sock, IIf(lcpt = 1, timeout, 1))
    If lBuffer = "" Then Exit Do
    If lBuffer = "-1" Then
        lBuffer = "999 Erreur de socket" & vbCrLf
    End If
    RecvStrTOFTP = RecvStrTOFTP & lBuffer
    If lBuffer Like "### *" Or lBuffer Like "*" & vbCrLf & "#### *" Then
        Exit Do
    End If
Loop
End Function

X-L-1. Connexion à un serveur sans proxy

Dans ce cas on se connecte directement au serveur FTP, puis on envoie les commandes d'authentification.
La connexion est identique à ce que nous avons réalisé précédemment pour l'envoi de mail par un serveur SMTP.

 
Sélectionnez

Function ConnectFTPSansProxy()
Dim lData As WSADATA
Dim lsock As Long
Dim lname As SOCKADDR
Dim lStrToSend As String
Dim lStrToReceive As String
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
   ' Création d'une socket
   lsock = socket(AF_INET, SOCK_STREAM, 0)
   If lsock <> -1 Then
       lname.sin_family = AF_INET ' famille "classique"
       ' Le port est généralement 21 pour du FTP
       lname.sin_port(1) = 21 \ 256 ' première partie du port
       lname.sin_port(2) = 21 Mod 256 ' deuxième partie du port
       lname.sin_addr = addrfromhost("MonSiteFTP.com") ' adresse du serveur
       ' Connexion
       If Connect(lsock, lname, LenB(lname)) = 0 Then
           ' Réception des données de connexion
           lStrToReceive = RecvStrTO(lsock)
           Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           ' Envoi du nom d'utilisateur
           lStrToSend = "USER monUtilisateur" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTOFTP(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Envoi du mot de passe
           lStrToSend = "PASS monMotDePasse" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTOFTP(lsock) 
                Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Quitte le serveur
           lStrToSend = "quit" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTOFTP(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
       Else
           Debug.Print "Erreur de connexion  " & Err.LastDllError
       End If
       closesocket lsock
   End If
   WSACleanup
End If
End Function


Et voici le résultat obtenu dans la fenêtre Exécution :

Octets reçus : 63
220 XX-XX-XX-XX.ovh.net NcFTPd Server (licensed copy) ready.

Commande envoyée :
USER monUtilisateur

Octets reçus : 40
331 User monUtilisateur okay, need password.

Commande envoyée :
PASS monMotDePasse

Octets reçus : 55
230-You are user #1 of 50 simultaneous users allowed.

Octets reçus : 38
230-
230 Restricted user logged in.

Commande envoyée :
quit

Octets reçus : 14
221 Goodbye.


À noter : je fais deux lectures de données après l'envoi du mot de passe car je ne récupère pas tout la première fois.
Sans doute qu'il y a deux envois de la part du serveur.


X-L-2. Connexion à un serveur avec proxy

Si vous êtes derrière un proxy, les commandes à envoyer dépendent du type de proxy.
Dans FileZilla, vous pouvez trouver les différents type de proxy dans le menu : Edition => Paramètres => Paramètres de proxy FTP.

Image non disponible
Dans mon cas, je dois choisir USER RemoteID@RemoteHost.

La commande est donc USER monUtilisateur@MonSiteFTP.com.

La fonction de connexion est similaire à la précédente sans proxy sauf que :
- la socket est connectée au proxy (remplacez monproxyftp par l'adresse de votre proxy) ;
- la commande USER contient le nom d'utilisateur et l'adresse du serveur FTP.

 
Sélectionnez

Function ConnectFTPAvecProxy()
Dim lData As WSADATA
Dim lsock As Long
Dim lname As SOCKADDR
Dim lStrToSend As String
Dim lStrToReceive As String
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
   ' Création d'une socket
   lsock = socket(AF_INET, SOCK_STREAM, 0)
   If lsock <> -1 Then
       lname.sin_family = AF_INET ' famille "classique"
       ' Le port est généralement 21 pour du FTP
       lname.sin_port(1) = 21 \ 256 ' première partie du port
       lname.sin_port(2) = 21 Mod 256 ' deuxième partie du port
       lname.sin_addr = addrfromhost("monproxyftp") ' adresse du serveur
       ' Connexion
       If Connect(lsock, lname, LenB(lname)) = 0 Then
           ' Réception des données de connexion
           lStrToReceive = RecvStrTOFTP(lsock)
           Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           ' Envoi du nom d'utilisateur
           lStrToSend = "USER monUtilisateur@MonSiteFTP.com" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTOFTP(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Envoi du mot de passe
           lStrToSend = "PASS monMotDePasse" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTOFTP(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Quitte le serveur
           lStrToSend = "quit" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTOFTP(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
       Else
           Debug.Print "Erreur de connexion  " & Err.LastDllError
       End If
       closesocket lsock
   End If
   WSACleanup
End If
End Function


Et voici le résultat obtenu dans la fenêtre Exécution :

Octets reçus : 27
220 Blue Coat FTP Service

Commande envoyée :
USER monUtilisateur@MonSiteFTP.comm

Octets reçus : 40
331 User monUtilisateur okay, need password.

Commande envoyée :
PASS monMotDePasse

Octets reçus : 93
230-You are user #2 of 50 simultaneous users allowed.
230-
230 Restricted user logged in.

Commande envoyée :
quit

Octets reçus : 41
221 Service closing control connection.

X-L-3. Liste des commandes FTP


Les commandes FTP sont normalisées et consultables ici : FILE TRANSFER PROTOCOL (FTP).

Une liste simplifiée est sur Wikipedia : List of FTP commands.

Vous pouvez également faire une opération avec FileZilla et regarder dans le journal des messages quelle est la commande envoyée.

X-L-4. Récupérer la liste des dossiers et fichiers (LIST)


Reprenons le code précédent (avec ou sans proxy en fonction de votre cas).
La suite du code s'écrit avant l'envoi de la commande "quit".

Si on regarde avec FileZilla, on s'aperçoit que celui-ci envoie les commandes suivantes :
- TYPE A : passage en mode ASCII (pour du texte car la liste est envoyée en texte ;
- PASV : passage en mode passif (le serveur envoie l'adresse où se connecter pour recevoir les données ;
- LIST : commande qui demande la liste des dossiers et fichiers.

Le mode passif est celui qui a le plus de chances d'aboutir.
C'est le serveur qui donne les informations de connexion au client.
Le mode actif serait défini par la commande PORT.
Pour plus d'information sur la différence entre les modes passif et actif, je vous invite à chercher sur internet où vous trouverez de meilleures explications que les miennes.

Ajoutons alors l'envoi de ces trois commandes :

 
Sélectionnez

[...]
           ' Type ASCII
           lStrToSend = "TYPE A" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTOFTP(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Mode passif
           lStrToSend = "PASV" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTOFTP(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Demande de la liste
           lStrToSend = "LIST" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTOFTP(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
[...]


Et voici le résultat obtenu pour ces trois commandes dans la fenêtre Exécution :

Commande envoyée :
TYPE A

Octets reçus : 16
200 Type okay.

Commande envoyée :
PASV

Octets reçus : 49
227 Entering Passive Mode (87,98,130,52,129,55)

Commande envoyée :
LIST

Octets reçus : 0


Pas de liste de fichiers en vue...
On obtient en fait, en retour de la commande PASV, l'adresse où se connecter pour récupérer la liste.
Les 4 premiers chiffres composent l'adresse IP, les 2 suivants le Port.
On se connecte à cette adresse avec une socket.

La connexion peut se faire juste après la commande PASV.
La lecture des données se fait après l'envoi de la commande LIST.
Le serveur attend notre connexion à la socket de données, c'est pour cela que la commande LIST n'a pas retourné d'information.

Pour récupérer les informations d'adresse, on peut utiliser l'instruction VBA Split.

Voici le code complet de connexion (à adapter si utilisation d'un proxy) et de récupération de la liste des dossiers et fichiers.

 
Sélectionnez

Function ConnectFTPSansProxy()
Dim lData As WSADATA
Dim lsock As Long
Dim lname As SOCKADDR
Dim lStrToSend As String
Dim lStrToReceive As String
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
   ' Création d'une socket
   lsock = socket(AF_INET, SOCK_STREAM, 0)
   If lsock <> -1 Then
       lname.sin_family = AF_INET ' famille "classique"
       ' Le port est généralement 21 pour du FTP
       lname.sin_port(1) = 21 \ 256 ' première partie du port
       lname.sin_port(2) = 21 Mod 256 ' deuxième partie du port
       lname.sin_addr = addrfromhost("monserveurftp") ' adresse du serveur
       ' Connexion
       If Connect(lsock, lname, LenB(lname)) = 0 Then
           ' Réception des données de connexion
           lStrToReceive = RecvStrTOFTP(lsock)
           Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           ' Envoi du nom d'utilisateur
           lStrToSend = "USER monUtilisateur" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTOFTP(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Envoi du mot de passe
           lStrToSend = "PASS monMotDePasse" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTOFTP(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Type ASCII
           lStrToSend = "TYPE A" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTOFTP(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Mode passif
           lStrToSend = "PASV" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTOFTP(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Création et connexion d'une socket de données
           Dim lsockdata As Long ' socket de données
           Dim lnamedata As SOCKADDR ' adresse de la socket de données
           lsockdata = socket(AF_INET, SOCK_STREAM, 0)
           If lsockdata <> -1 Then
               Dim lSplit As Variant ' tableau contenant les données entre parenthèses
               Dim lPos1 As Long, lPos2 As Long ' position des parenthèses
               lPos1 = InStr(lStrToReceive, "(") ' parenthèse ouvrante
               lPos2 = InStr(lPos1, lStrToReceive, ")") ' parenthèse fermante
               ' récupère les informations d'adresse dans un tableau (indice base 0 par défaut)
               lSplit = Split(Mid(lStrToReceive, lPos1 + 1, lPos2 - lPos1 - 1), ",")
               lnamedata.sin_family = AF_INET ' famille "classique"
               ' Le port est généralement 21 pour du FTP
               lnamedata.sin_port(1) = lSplit(4) ' première partie du port
               lnamedata.sin_port(2) = lSplit(5) ' deuxième partie du port
                ' adresse du serveur
               lnamedata.sin_addr = inet_addr(lSplit(0) & "." & lSplit(1) & "." & _
                                                lSplit(2) & "." & lSplit(3))
               ' Connexion
               If Connect(lsockdata, lnamedata, LenB(lnamedata)) = 0 Then
                   Debug.Print "connexion réussie à la socket de données" & vbCrLf
               End If
           End If
           ' Demande de la liste
           lStrToSend = "LIST" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTOFTP(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Récupère la liste sur la socket de données
           ' RecvStrTOFTP n'est pas utile ici, ce n'est pas un message du serveur mais des données
           lStrToReceive = RecvStrTO (lsockdata)
           Debug.Print "Liste : " & vbCrLf & lStrToReceive
           ' Ferme la socket de données
           closesocket lsockdata
           ' Quitte le serveur
           lStrToSend = "quit" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTOFTP(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
       Else
           Debug.Print "Erreur de connexion  " & Err.LastDllError
       End If
       closesocket lsock
   End If
   WSACleanup
End If
End Function


Et voici le résultat obtenu dans la fenêtre Exécution :

Octets reçus : 63
220 XX-XX-XX-XX.ovh.net NcFTPd Server (licensed copy) ready.

Commande envoyée :
USER monUtilisateur

Octets reçus : 40
331 User monUtilisateur okay, need password.

Commande envoyée :
PASS monMotDePasse

Octets reçus : 55
230-You are user #1 of 50 simultaneous users allowed.
230-
230 Restricted user logged in.

Commande envoyée :
TYPE A

Octets reçus : 16
200 Type okay.

Commande envoyée :
PASV

Octets reçus : 49
227 Entering Passive Mode (87,98,130,52,223,94)

connexion réussie à la socket de données

Commande envoyée :
LIST

Octets reçus : 76
150 Data connection accepted from 82.229.112.153:49767; transfer starting.

Liste :
drwxr-xr-x 8 developp developp 4096 Jan 27 2010 articles
drwxr-xr-x 5 developp developp 4096 Feb 9 14:26 fichiers
drwxr-xr-x 10 developp developp 4096 Jul 5 15:09 images
-rw-r--r-- 1 developp developp 15115 May 6 2010 index.php

Octets reçus : 24
226 Listing completed.

Commande envoyée :
quit

Octets reçus : 14
221 Goodbye.


La liste obtenue est une liste brute qu'il faut "découper" pour retrouver chaque information.

X-L-5. Télécharger un fichier (RETR)


Le téléchargement d'un fichier se fait suivant le même principe que pour la récupération de la liste d'un dossier.
Par contre il faut faire attention au type de transfert (ASCII ou Binaire).
Pour conserver le contenu original du fichier, il faut utiliser un mode Binaire (commande TYPE I).
Le mode ASCII ne convient que pour les fichiers textes qu'il adapte en fonction du système d'exploitation.
Comme nous avons créé une fonction RecvStrTO dédiée à la réception de texte, nous ne pouvons pas l'utiliser pour un contenu binaire de fichier.
De plus, un fichier peut être très volumineux ; il n'est pas concevable de récupérer tout le fichier en mémoire avant de l'écrire sur le disque.

Voici une fonction à ajouter au module modWinsock :

 
Sélectionnez

' -----------------------------------------------------------------------------
' Réception de données binaire sur une socket sock avec timeout en secondes
' -----------------------------------------------------------------------------
Public Function RecvBinTO(sock, Optional nbRead As Long = 1024, Optional timeout As Long = 10) As Variant
Dim lBuffer() As Byte
Dim lfdr As FD_SET, lfdw As FD_SET, lfde As FD_SET
Dim lret As Long
Dim lti As TIMEVAL
' Au moins un octet demandé
If nbRead = 0 Then Exit Function
' délai en secondes
lti.tv_sec = timeout
' une socket à vérifier
lfdr.fd_count = 1
' la socket passée en paramètre
lfdr.fd_array(1) = sock
' la socket est-elle prête?
lret = wselect(0, lfdr, lfdw, lfde, lti)
' Si pas d'erreur et délai non dépassé
If lret > 0 Then
    ' Si socket prête
    If lfdr.fd_count = 1 Then
        ' Buffer de réception
        ReDim lBuffer(1 To nbRead)
        ' Réception binaire
        lret = recv(sock, lBuffer(1), nbRead, 0)
        ' Redimensionne le buffer en fonction des données reçues
        If lret > 0 Then
            ReDim Preserve lBuffer(1 To lret)
            nbRead = lret
        ElseIf lret <= 0 Then
            Erase lBuffer
            nbRead = 0
        End If
    End If
Else
    nbRead = 0
End If
RecvBinTO = lBuffer
End Function


Cette fonction renvoie un tableau d'octets.
nbRead est la taille des données à lire (1024 octets par défaut).
nbRead est modifié par la fonction et contient ensuite la taille des données effectivement lues.
Il faut appeler cette fonction jusqu'à ce que nbRead soit à 0, c'est-à-dire qu'il n'y a plus de données à lire.

Voici un exemple de téléchargement de fichier :

 
Sélectionnez

Function ConnectFTPSansProxy()
Dim lData As WSADATA
Dim lsock As Long
Dim lname As SOCKADDR
Dim lStrToSend As String
Dim lStrToReceive As String
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
   ' Création d'une socket
   lsock = socket(AF_INET, SOCK_STREAM, 0)
   If lsock <> -1 Then
       lname.sin_family = AF_INET ' famille "classique"
       ' Le port est généralement 21 pour du FTP
       lname.sin_port(1) = 21 \ 256 ' première partie du port
       lname.sin_port(2) = 21 Mod 256 ' deuxième partie du port
       lname.sin_addr = addrfromhost("monserveurftp") ' adresse du serveur
       ' Connexion
       If Connect(lsock, lname, LenB(lname)) = 0 Then
           ' Réception des données de connexion
           lStrToReceive = RecvStrTOFTP(lsock)
           Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           ' Envoi du nom d'utilisateur
           lStrToSend = "USER monUtilisateur" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTOFTP(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Envoi du mot de passe
           lStrToSend = "PASS monMotDePasse" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTOFTP(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Type Binaire
           lStrToSend = "TYPE I" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTOFTP(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Mode passif
           lStrToSend = "PASV" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTOFTP(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Création et connexion d'une socket de données
           Dim lsockdata As Long ' socket de données
           Dim lnamedata As SOCKADDR ' adresse de la socket de données
           lsockdata = socket(AF_INET, SOCK_STREAM, 0)
           If lsockdata <> -1 Then
               Dim lSplit As Variant ' tableau contenant les données entre parenthèses
               Dim lPos1 As Long, lPos2 As Long ' position des parenthèses
               lPos1 = InStr(lStrToReceive, "(") ' parenthèse ouvrante
               lPos2 = InStr(lPos1, lStrToReceive, ")") ' parenthèse fermante
               ' récupère les informations d'adresse dans un tableau (indice base 0 par défaut)
               lSplit = Split(Mid(lStrToReceive, lPos1 + 1, lPos2 - lPos1 - 1), ",")
               lnamedata.sin_family = AF_INET ' famille "classique"
               ' Le port est généralement 21 pour du FTP
               lnamedata.sin_port(1) = lSplit(4) ' première partie du port
               lnamedata.sin_port(2) = lSplit(5) ' deuxième partie du port
                ' adresse du serveur
               lnamedata.sin_addr = inet_addr(lSplit(0) & "." & lSplit(1) & "." & _
                                                lSplit(2) & "." & lSplit(3))
               ' Connexion
               If Connect(lsockdata, lnamedata, LenB(lnamedata)) = 0 Then
                   Debug.Print "connexion réussie à la socket de données" & vbCrLf
               End If
           End If
           ' Demande du fichier monfichier.zip
           lStrToSend = "RETR monfichier.zip" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception du retour de la commande
               lStrToReceive = RecvStrTOFTP(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
               ' Réception des données et écriture du fichier
               Dim f As Integer, sfic As String, lbuffer() As Byte, lNbRead As Long, lTotalByte As Long
               sfic = "C:\monfichier.zip" ' fichier à écrire sur le pc
               If Len(Dir(sfic)) > 0 Then Kill sfic ' supprime le fichier si existe déjà
               ' ouvre le fichier sur le PC
               f = FreeFile
               Open ThisWorkbook.Path & "\officeweb.zip" For Binary As #f
               Do
                   lNbRead = 1024 ' lecture par paquet de 1024 octets
                   'réception de données
                   lbuffer = RecvBinTO(lsockdata, lNbRead, 2)
                   ' taille totale
                   lTotalByte = lTotalByte + lNbRead
                   ' si plus de données à recevoir
                   If lNbRead = 0 Then Exit Do
                   ' écrit les données dans le fichier
                   Put #f, , lbuffer
               Loop
               Close f ' ferme le fichier
               Debug.Print "Octets reçus dans le fichier: " & lTotalByte & vbCrLf
           End If
           ' Ferme la socket de données
           closesocket lsockdata
           ' Quitte le serveur
           lStrToSend = "quit" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
               ' Réception des données
               lStrToReceive = RecvStrTOFTP(lsock)
               Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
       Else
           Debug.Print "Erreur de connexion  " & Err.LastDllError
       End If
       closesocket lsock
   End If
   WSACleanup
End If
End Function


Avec les sockets, on récupère un buffer en mémoire contenant les données du fichier.
On écrit le fichier sur le disque avec les fonctions intégrées de VBA (open, put...).

X-L-6. Envoyer un fichier (STOR)


Pour envoyer un fichier, c'est le même principe avec la commande STOR à la place de RETR.
Bien entendu, au lieu de recevoir des données, on envoie des données à la socket lsockdata.
On peut lire le contenu du fichier à l'aide de l'instruction get de VBA.

X-M. Création d'un serveur

Les sockets sont utilisées dans le cadre d'un client/serveur.
Jusqu'ici nous n'avons développé que des clients, les serveurs étant des serveurs FTP ou SMTP sur internet.

Nous allons maintenant développer un petit serveur.

Le serveur se compose également d'un (ou plusieurs) socket(s).
Par contre on n'utilise pas la fonction connect mais les fonctions bind, listen et accept.

déclaration des fonctions serveur dans modWinsock
Sélectionnez

Public Declare Function bind Lib "ws2_32.dll" (ByVal hSocket As Long, ByRef Name As SOCKADDR, ByVal NameLen As Long) As Long
Public Declare Function listen Lib "ws2_32.dll" (ByVal hSocket As Long, ByVal BackLog As Long) As Long
Public Declare Function accept Lib "ws2_32.dll" (ByVal hSocket As Long, ByRef SocketAddress As SOCKADDR, _
                                                 ByRef AddrLen As Long) As Long
Autres fonctions utiles dans modWinsock
Sélectionnez

Public Declare Function getsockname Lib "ws2_32.dll" (ByVal hSocket As Long, ByRef Name As SOCKADDR, ByRef NameLen As Long) As Long
Public Declare Function WSAAddressToString Lib "ws2_32.dll" Alias "WSAAddressToStringA" _
                       (ByRef lpsaAddress As SOCKADDR, ByVal dwAddressLength As Long, _
                        ByVal lpProtocolInfo As Long, ByVal lpszAddressString As String, _
                        ByRef lpdwAddressStringLength As Long) As Long


-bind définit l'adresse et le port d'écoute du serveur (un serveur peut avoir plusieurs adresses IP).
-listen place une socket dans un statut d'écoute (prête à recevoir des connexions).
-accept permet d'accepter ou rejeter une tentative de connexion d'un client.

J'ai ajouté deux autres fonctions :
-getsockname qui permet de trouver les informations d'adresse d'une socket ;
-WSAAddressToString qui permet de trouver une adresse IP "en clair".

WSAAddressToString est disponible à partir de Winsock 2. Pour les versions précédentes, il faut utiliser inet_ntoa qui est un peu plus complexe.

Voici un exemple de module pour un serveur (très simpliste) sur Excel (devrait fonctionner aussi sous Word) :

Module serveur pour Excel
Sélectionnez

Option Explicit
            
Dim ServerSock As Long ' Socket serveur
Dim ClientSocks As FD_SET ' Sockets client
            
' Vérifie si un client a envoyé des données
Public Function ServerCheckRecv()
Dim fdr As FD_SET, fdw As FD_SET, fde As FD_SET
Dim ti As TIMEVAL
Dim lname As SOCKADDR
Dim sStrToRecv As String
Dim cpt As Long
' Timeout à zéro seconde
ti.tv_sec = 0
' Fait une copie de la structure contenant les clients (fdr est modifiée par wselect)
LSet fdr = ClientSocks
If wselect(0, fdr, fdw, fde, ti) > 0 Then
   ' Pour chaque client ayant envoyé des données
   For cpt = 1 To fdr.fd_count
       ' Lit les données
       sStrToRecv = RecvStrTO(fdr.fd_array(cpt), 0)
       ' Ecrit les données reçues dans la fenêtre Exécution
       If sStrToRecv <> "" Then Debug.Print sStrToRecv
   Next
End If
' Relance cette procédure dans une seconde
If ServerSock <> 0 Then Application.OnTime DateAdd("s", 1, Now), "ServerCheckRecv"
End Function
            
' Vérifie si une connexion est en attente et l'accepte
Public Function ServerCheckAccept()
Dim fdr As FD_SET, fdw As FD_SET, fde As FD_SET
Dim ti As TIMEVAL
Dim lname As SOCKADDR
Dim lConnexionSocket As Long
Dim saddr As String, saddrlen As Long
' Timeout à zéro seconde
ti.tv_sec = 0
fdr.fd_count = 1
' Vérifie la socket serveur pour les connexions en attente
fdr.fd_array(1) = ServerSock
' Si une connexion est en attente
If wselect(0, fdr, fdw, fde, ti) > 0 Then
   ' Accepte la connexion
   ' lConnexionSocket est la socket connectée
   lConnexionSocket = accept(ServerSock, lname, LenB(lname))
   ' Ajoute la socket client à la structure ClientSocks
   ClientSocks.fd_count = ClientSocks.fd_count + 1
   ClientSocks.fd_array(ClientSocks.fd_count) = lConnexionSocket
   ' Récupère l'adresse de la socket client
   saddrlen = 256
   saddr = Space(saddrlen)
   WSAAddressToString lname, LenB(lname), 0, saddr, saddrlen
   saddr = Left(saddr, saddrlen - 1)
   ' Envoie au client un message de connexion
   SendStrTO lConnexionSocket, saddr & " Connected OK"
End If
' Relance cette procédure dans une seconde
If ServerSock <> 0 Then Application.OnTime DateAdd("s", 1, Now), "ServerCheckAccept"
End Function
            
' Lance le serveur
Function RunServeur()
Dim lData As WSADATA
Dim lname As SOCKADDR
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
   ' Création d'une socket serveur
   ServerSock = socket(AF_INET, SOCK_STREAM, 0)
   If ServerSock <> -1 Then
       lname.sin_family = AF_INET ' famille "classique"
       lname.sin_port(1) = 1025 \ 256 ' première partie du port
       lname.sin_port(2) = 1025 Mod 256 ' deuxième partie du port
       lname.sin_addr = inet_addr("127.0.0.1") ' adresse de la boucle local
       ' Lie la socket
       If bind(ServerSock, lname, LenB(lname)) = 0 Then
           ' Place la socket en écoute
       ' 20 est le nombre maximal de clients en attente de connexion
           If listen(ServerSock, 20) = 0 Then
               ' Exécute les fonctions d'acceptation et de réception dans une seconde
               Application.OnTime DateAdd("s", 1, Now), "ServerCheckAccept"
               Application.OnTime DateAdd("s", 1, Now), "ServerCheckRecv"
           End If
       End If
   End If
End If
End Function
            
' Arrête le serveur
Function StopServeur()
Dim cpt As Long
' Ferme toutes les connexions
For cpt = 1 To ClientSocks.fd_count
   closesocket ClientSocks.fd_array(cpt)
Next
ClientSocks.fd_count = 0
' Ferme la socket serveur
closesocket ServerSock
ServerSock = 0
' Purge Winsock
WSACleanup
End Function


Les fonctions ServerCheckRecv et ServerCheckAccept sont exécutées périodiquement toutes les secondes grâce à l'instruction OnTime.
Sous Access, on pourrait utiliser la minuterie d'un formulaire.

Démarrez le serveur avec RunServer et arrêtez-le avec StopServeur.

Pour cet exemple, j'ai spécifié l'adresse 127.0.0.1 qui est la boucle locale du PC.
C'est-à-dire que seul le PC sur lequel s'exécute le serveur peut communiquer avec lui.
Vous pouvez mettre l'adresse IP de la carte réseau du PC à la place.
Le client devra alors utiliser cette adresse également.
Remarque : mettez l'élément sin_addr à zéro (0) pour écouter sur toutes les IP de la machine.

Concernant le port d'écoute, j'ai mis arbitrairement 1025 : ce port ne doit pas déjà être utilisé.
On peut mettre le port à 0 pour que la fonction bind recherche elle-même un port libre.
La fonction getsockname permet alors de retrouver le port utilisé : le client devra spécifier ce port à la connexion.

Le serveur seul ne fait rien, il faut développer une partie client.
Ce client devra être un autre fichier Excel exécuté dans une application distincte de celle du serveur.
Créez un nouveau fichier dans le lequel vous copiez le module modWinsock.
Ajoutez ensuite un nouveau module client :

Module Client
Sélectionnez

Option Explicit
            
' Se connecte au serveur
Function RunClient()
Dim lData As WSADATA
Dim lClientSock As Long
Dim lServerName As SOCKADDR
Dim lClientName As SOCKADDR
Dim lstrToRecv As String
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
   ' Création d'une socket
   lClientSock = socket(AF_INET, SOCK_STREAM, 0)
   ' Adresse de connexion
   lServerName.sin_family = AF_INET
   lServerName.sin_port(1) = 1025 \ 256
   lServerName.sin_port(2) = 1025 Mod 256
   lServerName.sin_addr = inet_addr("127.0.0.1")
   ' Connexion
   If Connect(lClientSock, lServerName, LenB(lServerName)) = 0 Then
       ' Lecture information de la socket client
       If getsockname(lClientSock, lClientName, LenB(lClientName)) = 0 Then
           Debug.Print "Port socket Client: " & lClientName.sin_port(1) * 256 + lClientName.sin_port(2)
       End If
       ' Lecture de l'information de connexion envoyée par le serveur
       lstrToRecv = RecvStrTO(lClientSock)
       Debug.Print "Reçu : " & lstrToRecv
   End If
   ' Ferme la socket
   closesocket lClientSock
   ' Purge Winsock
   WSACleanup
End If
End Function


Ce client est très simple : il se connecte au serveur et récupère l'information de connexion.
Il se déconnecte ensuite tout de suite.

Notez que ce client pourrait tourner sous Word ou Access par exemple, et se connecter à un serveur sous Excel.

Pour tester, exécutez RunServeur sur une application, et RunClient sur l'autre.
Exécutez ensuite StopServeur pour ne pas laisser tourner le serveur inutilement.

Voici le résultat obtenu côté client :

Port socket Client: 4762
Reçu : 127.0.0.1:4762 Connected OK


Avec getsockname côté client, on a récupéré le port de la socket client.
Ce port est différent de celui du serveur : chaque client a besoin d'un port.

L'information reçue provient du serveur :
Celui-ci récupère l'adresse IP et le port du client grâce à la fonction WSAAddressToString.

Ce client-serveur assez simple permet, je l'espère, de comprendre les bases pour développer des applications plus complexes.
Il est possible de connecter plusieurs clients à un serveur distant et de programmer un chat par exemple.

X-N. Module modWinsock

Voici le code du module modWinsock utilisé dans les chapitres précédents :

Module modWinsock
Sélectionnez
'***************************************************************************************
'* Procédures pour winsock
'***************************************************************************************
Option Explicit

#If VBA7 Then
DefLngPtr a - Z
#Else
DefLng A-Z
#End If

#If VBA7 Then
Public Declare PtrSafe Function WSAGetLastError Lib "ws2_32.dll" () As Long
Public Declare PtrSafe Function WSAStartup Lib "ws2_32.dll" (ByVal wVersionRequested As Integer, ByRef lpWSAData As WSADATA) As Long
Public Declare PtrSafe Function WSACleanup Lib "ws2_32.dll" () As Long
Public Declare PtrSafe Function socket Lib "ws2_32.dll" (ByVal AddressFamily As Long, ByVal SocketType As Long, ByVal Protocol As Long) As LongPtr
Public Declare PtrSafe Function closesocket Lib "ws2_32.dll" (ByVal hSocket As LongPtr) As Long
Public Declare PtrSafe Function connect Lib "ws2_32.dll" (ByVal hSocket As LongPtr, ByRef Name As SOCKADDR, ByVal NameLen As Long) As Long
Public Declare PtrSafe Function gethostbyname Lib "ws2_32.dll" (ByVal Name As String) As LongPtr
Public Declare PtrSafe Function inet_addr Lib "ws2_32.dll" (ByVal IpAddress As String) As Long
Public Declare PtrSafe Function send Lib "ws2_32.dll" (ByVal hSocket As LongPtr, ByRef buffer As Any, ByVal BufferLength As Long, ByVal flags As Long) As Long
Public Declare PtrSafe Function sendstr Lib "ws2_32.dll" Alias "send" (ByVal hSocket As LongPtr, ByVal buffer As String, ByVal BufferLength As Long, ByVal flags As Long) As Long
Public Declare PtrSafe Function recv Lib "ws2_32.dll" (ByVal hSocket As LongPtr, ByRef buffer As Any, ByVal BufferLength As Long, ByVal flags As Long) As Long
Public Declare PtrSafe Function recvstr Lib "ws2_32.dll" Alias "recv" (ByVal hSocket As LongPtr, ByVal buffer As String, ByVal BufferLength As Long, ByVal flags As Long) As Long
Public Declare PtrSafe Function wselect Lib "ws2_32.dll" Alias "select" (ByVal Reserved As Long, ByRef ReadFds As FD_SET, ByRef WriteFds As FD_SET, ByRef ExceptFds As FD_SET, ByRef timeout As TIMEVAL) As Long
Public Declare PtrSafe Function bind Lib "ws2_32.dll" (ByVal hSocket As LongPtr, ByRef Name As SOCKADDR, ByVal NameLen As Long) As Long
Public Declare PtrSafe Function listen Lib "ws2_32.dll" (ByVal hSocket As LongPtr, ByVal BackLog As Long) As Long
Public Declare PtrSafe Function accept Lib "ws2_32.dll" (ByVal hSocket As LongPtr, ByRef SocketAddress As SOCKADDR, ByRef AddrLen As Long) As Long
Public Declare PtrSafe Function getsockname Lib "ws2_32.dll" (ByVal hSocket As LongPtr, ByRef Name As SOCKADDR, ByRef NameLen As Long) As Long
Public Declare PtrSafe Function WSAAddressToString Lib "ws2_32.dll" Alias "WSAAddressToStringA" _
                        (ByRef lpsaAddress As SOCKADDR, ByVal dwAddressLength As Long, _
                         ByVal lpProtocolInfo As Long, ByVal lpszAddressString As String, _
                         ByRef lpdwAddressStringLength As Long) As Long
Public Declare PtrSafe Function CryptBinaryToString Lib "crypt32.dll" Alias "CryptBinaryToStringA" (ByVal pbBinary As String, ByVal cbBinary As Long, ByVal dwFlags As Long, ByVal pszString As String, ByRef pcchString As Long) As Long
Public Declare PtrSafe Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, Source As Any, ByVal length As LongPtr)
#Else
Public Declare Function WSAGetLastError Lib "ws2_32.dll" () As Long
Public Declare Function WSAStartup Lib "ws2_32.dll" (ByVal wVersionRequested As Integer, ByRef lpWSAData As WSADATA) As Long
Public Declare Function WSACleanup Lib "ws2_32.dll" () As Long
Public Declare Function socket Lib "ws2_32.dll" (ByVal AddressFamily As Long, ByVal SocketType As Long, ByVal Protocol As Long) As Long
Public Declare Function closesocket Lib "ws2_32.dll" (ByVal hSocket As Long) As Long
Public Declare Function connect Lib "ws2_32.dll" (ByVal hSocket As Long, ByRef Name As SOCKADDR, ByVal NameLen As Long) As Long
Public Declare Function gethostbyname Lib "ws2_32.dll" (ByVal Name As String) As Long
Public Declare Function inet_addr Lib "ws2_32.dll" (ByVal IpAddress As String) As Long
Public Declare Function send Lib "ws2_32.dll" (ByVal hSocket As Long, ByRef buffer As Any, ByVal BufferLength As Long, ByVal flags As Long) As Long
Public Declare Function sendstr Lib "ws2_32.dll" Alias "send" (ByVal hSocket As Long, ByVal buffer As String, ByVal BufferLength As Long, ByVal flags As Long) As Long
Public Declare Function recv Lib "ws2_32.dll" (ByVal hSocket As Long, ByRef buffer As Any, ByVal BufferLength As Long, ByVal flags As Long) As Long
Public Declare Function recvstr Lib "ws2_32.dll" Alias "recv" (ByVal hSocket As Long, ByVal buffer As String, ByVal BufferLength As Long, ByVal flags As Long) As Long
Public Declare Function wselect Lib "ws2_32.dll" Alias "select" (ByVal Reserved As Long, ByRef ReadFds As FD_SET, ByRef WriteFds As FD_SET, ByRef ExceptFds As FD_SET, ByRef timeout As TIMEVAL) As Long
Public Declare Function bind Lib "ws2_32.dll" (ByVal hSocket As Long, ByRef Name As SOCKADDR, ByVal NameLen As Long) As Long
Public Declare Function listen Lib "ws2_32.dll" (ByVal hSocket As Long, ByVal BackLog As Long) As Long
Public Declare Function accept Lib "ws2_32.dll" (ByVal hSocket As Long, ByRef SocketAddress As SOCKADDR, ByRef AddrLen As Long) As Long
Public Declare Function getsockname Lib "ws2_32.dll" (ByVal hSocket As Long, ByRef Name As SOCKADDR, ByRef NameLen As Long) As Long
Public Declare Function WSAAddressToString Lib "ws2_32.dll" Alias "WSAAddressToStringA" _
                        (ByRef lpsaAddress As SOCKADDR, ByVal dwAddressLength As Long, _
                         ByVal lpProtocolInfo As Long, ByVal lpszAddressString As String, _
                         ByRef lpdwAddressStringLength As Long) As Long
Public Declare Function CryptBinaryToString Lib "crypt32.dll" Alias "CryptBinaryToStringA" (ByVal pbBinary As String, ByVal cbBinary As Long, ByVal dwFlags As Long, ByVal pszString As String, ByRef pcchString As Long) As Long
Public Declare Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, Source As Any, ByVal length As Long)
#End If
Public Type FD_SET
  fd_count     As Long
#If VBA7 Then
  fd_array(1 To 64) As LongPtr
#Else
  fd_array(1 To 64) As Long
#End If
End Type

Public Type TIMEVAL
  tv_sec  As Long
  tv_usec As Long
End Type

#If VBA7 Then
Public Type HOSTENT
  hName     As LongPtr
  hAliases  As LongPtr
  hAddrType As Integer
  hLength   As Integer
  hAddrList As LongPtr
End Type
#Else
Public Type HOSTENT
  hName     As Long
  hAliases  As Long
  hAddrType As Integer
  hLength   As Integer
  hAddrList As Long
End Type
#End If

Public Type SOCKADDR
  sin_family As Integer
  sin_port(1 To 2) As Byte ' équivalent de u_short
#If VBA7 Then
  sin_addr   As Long       'structure IN_ADDR
#Else
  sin_addr   As Long       'structure IN_ADDR
#End If
  sin_zero   As String * 7
End Type

Public Type WSADATA
  wVersion       As Integer
  wHighVersion   As Integer
  szDescription  As String * 256
  szSystemStatus As String * 128
  iMaxSockets    As Integer
  iMaxUdpDg      As Integer
#If VBA7 Then
  lpVendorInfo   As LongPtr
#Else
  lpVendorInfo   As Long
#End If
End Type

Public Const AF_INET = 2
Public Const SOCK_STREAM = 1
Public Const CRYPT_STRING_BASE64 = 1
Public Const MSG_DONTWAIT As Long = &H40

' -------------------------------------------------------------
' Donnez un nom de serveur en entrée: par exemple smtp.free.fr
' Retourne un entier long pour utilisation dans sin_addr
' WSAStartup doit être exécuté avant cette fonction
' -------------------------------------------------------------
Public Function addrfromhost(Host As String) As Long
Dim lHostEnt As HOSTENT
Dim lHost
Dim lAddress() As Byte
Dim lHostAddress
    ' lhost est un pointeur vers une structure HOSTENT
    lHost = gethostbyname(Host)
    If lHost <> 0 Then
        ' Déplace le contenu mémoire à l'emplacement du pointeur lHost vers la structure lHostEnt
        RtlMoveMemory lHostEnt, ByVal lHost, LenB(lHostEnt)
        ' Prépare un tableau contenant les 4 parties de l'addresse
        ReDim lAddress(1 To lHostEnt.hLength) As Byte
        ' Récupère le pointeur de l'adresse dans lHostAddress
        ' hAddrList est un pointeur vers un pointeur
        RtlMoveMemory lHostAddress, ByVal lHostEnt.hAddrList, lHostEnt.hLength
        ' Déplace l'adresse dans le tableau lAddress
        RtlMoveMemory lAddress(1), ByVal lHostAddress, lHostEnt.hLength
        ' Transforme l'adresse (ex : 212.29.48.4) en entier long avec inet_addr
        '  et retourne cette valeur
        addrfromhost = inet_addr(lAddress(1) & "." & lAddress(2) & "." & lAddress(3) & "." & lAddress(4))
    End If
End Function

' -----------------------------------------------------------------------------
' Réception de données (String) depuis FTP (attente d'un code suivi d'un espace)
' Cf. RFC 959, section 4.2
' -----------------------------------------------------------------------------
Public Function RecvStrTOFTP(sock, Optional timeout As Long = 15) As String
Dim lBuffer As String
Dim lPos As Long
Dim lcpt As Long
Do
    lcpt = lcpt + 1
    lBuffer = RecvStrTO(sock, IIf(lcpt = 1, timeout, 1))
    If lBuffer = "" Then Exit Do
    If lBuffer = "-1" Then
        lBuffer = "999 Erreur de socket" & vbCrLf
    End If
    RecvStrTOFTP = RecvStrTOFTP & lBuffer
    If lBuffer Like "### *" Or lBuffer Like "*" & vbCrLf & "#### *" Then
        Exit Do
    End If
Loop
End Function

' -----------------------------------------------------------------------------
' Réception de données (String) sur une socket sock avec timeout en secondes
' Si retour = -1 => erreur
' -----------------------------------------------------------------------------
Public Function RecvStrTO(sock, Optional timeout As Long = 10) As String
Dim lBuffer As String
Dim lfdr As FD_SET, lfdw As FD_SET, lfde As FD_SET
Dim lret As Long
Dim lti As TIMEVAL
' délai en secondes
lti.tv_sec = timeout
' une socket à vérifier
lfdr.fd_count = 1
' la socket passée en paramètre
lfdr.fd_array(1) = sock
' la socket est-elle prête?
lret = wselect(0, lfdr, lfdw, lfde, lti)
' Si pas d'erreur et délai non dépassé
If lret > 0 Then
    ' Boucle tant qu'il y a des données
    Do
        ' Si socket prête
        If lfdr.fd_count = 1 Then
            ' Réception
            lBuffer = Space(1024)
            lret = recvstr(sock, lBuffer, 1024, 0)
            ' Ajoute les données reçues au résultat
            If lret > 0 Then
                lBuffer = Left(lBuffer, lret)
                RecvStrTO = RecvStrTO & lBuffer
            ElseIf lret = 0 Then
                Exit Do
            ElseIf lret < 0 Then
                RecvStrTO = "-1"
                Exit Do
            End If
        End If
        ' Vérifie s'il y a encore des données à recevoir (avec délai à 1 usec)
        lfdr.fd_count = 1
        lti.tv_sec = 0
        lti.tv_usec = 1
        lret = wselect(0, lfdr, lfdw, lfde, lti)
        If lret <= 0 Then
               Exit Do
        End If
    Loop
End If
End Function

' -----------------------------------------------------------------------------
' Envoi de données (String) sur une socket sock avec timeout en secondes
' Cette fonction renvoit True si l'envoi est correct
' -----------------------------------------------------------------------------
Public Function SendStrTO(sock, ByVal StrToSend As String, Optional timeout As Long = 10) As Boolean
Dim lBuffer As String
Dim lfdr As FD_SET, lfdw As FD_SET, lfde As FD_SET
Dim lret As Long
Dim lti As TIMEVAL
' délai en secondes
lti.tv_sec = timeout
' une socket à vérifier
lfdw.fd_count = 1
' la socket passée en paramètre
lfdw.fd_array(1) = sock
' la socket est-elle prête?
lret = wselect(0, lfdr, lfdw, lfde, lti)
' Si pas d'erreur et délai non dépassé
If lret > 0 Then
    ' Boucle tant qu'il y a des données à envoyer
    Do
        ' Si socket prête
        If lfdw.fd_count = 1 Then
            ' Envoi
            lret = sendstr(sock, StrToSend, Len(StrToSend), 0)
            ' Test le retour
            If lret = -1 Then
                ' Erreur
                SendStrTO = False
                Exit Do
            Else
                If lret < Len(StrToSend) Then
                    ' Envoi partiel
                    StrToSend = Mid(StrToSend, lret + 1)
                Else
                    ' Envoi terminé
                    SendStrTO = True
                    Exit Do
                End If
            End If
        End If
    Loop
End If
End Function

' -----------------------------------------------------------------------------
' Codage Base64
' -----------------------------------------------------------------------------
Public Function Base64(ByVal pStr As String) As String
  Dim lStrReturn As String
  Dim lStrLen As Long
  ' Récupère la taille nécessaire
  Call CryptBinaryToString(pStr, Len(pStr), CRYPT_STRING_BASE64, vbNullString, lStrLen)
  If (lStrLen > 0) Then
      lStrReturn = Space$(lStrLen - 1) ' on retire le chr(0) final
      ' Code en Base64
      Call CryptBinaryToString(pStr, Len(pStr), CRYPT_STRING_BASE64, lStrReturn, lStrLen - 1)
  End If
  Base64 = lStrReturn
End Function

' -----------------------------------------------------------------------------
' Réception de données binaire sur une socket sock avec timeout en secondes
' -----------------------------------------------------------------------------
Public Function RecvBinTO(sock, Optional nbRead As Long = 1024, Optional timeout As Long = 10) As Variant
Dim lBuffer() As Byte
Dim lfdr As FD_SET, lfdw As FD_SET, lfde As FD_SET
Dim lret As Long
Dim lti As TIMEVAL
' Au moins un octet demandé
If nbRead = 0 Then Exit Function
' délai en secondes
lti.tv_sec = timeout
' une socket à vérifier
lfdr.fd_count = 1
' la socket passée en paramètre
lfdr.fd_array(1) = sock
' la socket est-elle prête?
lret = wselect(0, lfdr, lfdw, lfde, lti)
' Si pas d'erreur et délai non dépassé
If lret > 0 Then
    ' Si socket prête
    If lfdr.fd_count = 1 Then
        ' Buffer de réception
        ReDim lBuffer(1 To nbRead)
        ' Réception binaire
        lret = recv(sock, lBuffer(1), nbRead, 0)
        ' Redimensionne le buffer en fonction des données reçues
        If lret > 0 Then
            ReDim Preserve lBuffer(1 To lret)
            nbRead = lret
        ElseIf lret <= 0 Then
            Erase lBuffer
            nbRead = 0
        End If
    End If
Else
    nbRead = 0
End If
RecvBinTO = lBuffer
End Function

' -----------------------------------------------------------------------------
' Envoi de données (Bytes) sur une socket sock avec timeout en secondes
' Cette fonction renvoit True si l'envoi est correct
' -----------------------------------------------------------------------------
Public Function SendBinTO(sock, ByteToSend() As Byte, Optional timeout As Long = 10, Optional pCallBackObject As Object) As Boolean
Dim lfdr As FD_SET, lfdw As FD_SET, lfde As FD_SET
Dim lret As Long
Dim lti As TIMEVAL
Dim lBuffer() As Byte
Dim lTotal As Long
Dim lLeft As Long
Dim lSent As Long
Dim lToSend As Long
Dim lCancel As Boolean, lLog As String
Dim lubound As Long
' Contenu vide
lubound = -1
On Error Resume Next
lubound = UBound(ByteToSend)
On Error GoTo 0
If lubound = -1 Then SendBinTO = True: Exit Function
' délai en secondes
lti.tv_sec = timeout
' une socket à vérifier
lfdw.fd_count = 1
' la socket passée en paramètre
lfdw.fd_array(1) = sock
' la socket est-elle prête?
lret = wselect(0, lfdr, lfdw, lfde, lti)
' Si pas d'erreur et délai non dépassé
If lret > 0 Then
' Si socket prête
If lfdw.fd_count = 1 Then
    ' Boucle tant qu'il y a des données à envoyer
    lTotal = UBound(ByteToSend) - LBound(ByteToSend) + 1
    lLeft = UBound(ByteToSend) - LBound(ByteToSend) + 1
    lSent = 0
    Do
        If lLeft >= 1024 * 100& Then
            lToSend = 1024 * 100&
        Else
            lToSend = lLeft
        End If
        ReDim lBuffer(1 To lToSend)
        RtlMoveMemory lBuffer(1), ByteToSend(lSent + LBound(ByteToSend)), lToSend
        ' Envoi
        lret = send(sock, lBuffer(1), lToSend, 0)
        ' Test le retour
        If lret = -1 Then
            ' Erreur
            SendBinTO = False
            Exit Do
        Else
            lSent = lSent + lret
            lLeft = lLeft - lret
            
            If Not pCallBackObject Is Nothing Then
                lLog = Format(lSent / lTotal, "0%")
                If Len(lLog) < 4 Then lLog = Space$(4 - Len(lLog)) & lLog
                CallByName pCallBackObject, "FTPTransfertCallBack", VbMethod, lLog, lCancel
                If lCancel Then
                    'GetFile = GetFile & SendCommand("ABOR")
                    SendBinTO = False
                    Exit Do
                End If

            End If
            
            If lLeft <= 0 Then
                SendBinTO = True
                Exit Do
            End If
        End If
    Loop
End If
End If
End Function

X-O. Compatibilité avec Office 64 bits

À partir d'Access 2010, une version 64 bits d'Office est disponible et demande une adaptation du code : Développer avec Office 64 bits.
Les identifiants de socket notamment doivent être des LongPtr pour Office 64 bits.

Le module modWinsock précédent est compatible 64 bits. ;o)

X-P. Connexion SSL sécurisée

Certains serveurs requièrent une connexion SSL sécurisée.

À ce jour, je n'ai pas encore pu passer assez de temps sur le sujet pour aboutir à une connexion sécurisée en VBA.
Une piste serait sans doute d'utiliser la librairie crypt32.dll apparue avec XP.

Le sujet est complexe, le chemin est long...

X-Q. Conclusion Winsock

Nous avons vu que Winsock permet de développer des dialogues client-serveur avancés, mais au prix d'efforts de programmation non négligeables.

Les codes donnés dans cet article sont loin d'être aboutis :
- il y a peu de gestion d'erreurs. ;
- il faudrait ajouter de nombreuses fonctions utiles, comme par exemple envoyer une commande et recevoir la réponse en une seule fonction ;
- et un module de classe pour gérer l'objet socket serait fort utile.

De plus nous n'avons utilisé que quelques fonctions de l'API. Il y en a beaucoup d'autres mais je ne les maîtrise pas toutes.


précédentsommairesuivant

Vous avez aimé ce tutoriel ? Alors partagez-le en cliquant sur les boutons suivants : Viadeo Twitter Facebook Share on Google+   

  

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 © 2011 Thierry GASPERMENT. 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. Droits de diffusion permanents accordés à Developpez LLC.