VBA et dveloppement Web

Image non disponible


prcdentsommairesuivant

10. API Winsock

 

Commenons par une petite traduction: l'lment 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 prcdent), Winsock est une librairie dont nous devons dclarer les fonctions, types et constantes utiliss.

Il est possible que vous ayez votre disposition le contrle ActiveX Winsock.
Celui est install avec VB6 et avec certaines versions d'Office.
Pour l'utilisation de ce contrle, je vous renvoie vers des tutoriels crits pour VB6 mais dont le code est similaire en VBA:
- VB et les rseaux;
- 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 conserve pour compatibilit.

10-A. Module VBA modWinsock

Nous allons avoir besoin de dclarer les fonctions, types et constantes de l'API.
De plus, il sera utile de crer quelques fonctions personnalises pour effectuer des actions rptitives.

Crons donc un module VBA que nous appelons modWinSock.
Les fonctions utilises dans les chapitres suivants seront ajoutes ce module.

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

10-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 paramtres:
- wVersionRequested est la version minimale requise par le programme;
- lpWSAData est une structure de type WSADATA qui reoit 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.

Aprs excution de WSAStartup, la structure lData contient:
- une description szDescription: "WinSock 2.0" par exemple;
- un statut szSystemStatus: "Running" par exemple;
- la version demande wVersion: 257 pour notre exemple;
- la version maximale supporte 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 dtaills ici: Windows Sockets Error Codes.

10-C. Crer une socket

La socket est l'lment de base toute connexion.
Pour la crer, nous utilisons la fonction socket.

dclaration 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 dfinit la famille d'adresse;
- SOCK_STREAM qui dfinit 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 dclar la fonction closesocket pour fermer la socket aprs utilisation.

Utilisons ces fonctions pour crer une socket:

cration de socket
Sélectionnez

Function tuto1()
Dim lData As WSADATA
Dim lsock As Long
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
   ' Cration 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 cration de fonctionne pas, la fonction renvoie -1 et il faut lire la valeur de Err.LastDllError pour connatre le code d'erreur.

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

10-D. Connecter une socket

Une socket peut tre connecte un serveur pourvu que celui-ci accepte des connexions .

Si vous tes derrire 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 dclare ainsi:

dclaration 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 paramtres:
- hSocket est l'identifiant de la socket cre 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 lment sin_family est gal AF_INET comme pour l'appel la fonction socket;
- le deuxime lment sin_port est le port cibl (25) ; voir la suite pour le dtail;
- le troisime lment sin_addr est l'adresse du serveur cibl (smtp.free.fr) ; voir la suite pour le dtail;
- le quatrime lment sin_zero est inutilis.

Voici dj 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
   ' Cration 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 paramtrage 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.

10-E. Le port sin_port

L'lment sin_port est un entier non sign (u_short en C).
Sa valeur est de 0 65535, stocke 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".

dclaration 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 stocke 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 problme survient si on souhaite utiliser le port 50000 par exemple. La fonction htons renvoie une erreur en VBA car 50000 dpasse 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 dclar sin_port en tableau de deux bytes.
Il nous suffit de calculer nous-mmes les deux bytes:
- la premire valeur: 50000 \ 256 = 195
- la deuxime 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 paramtrage du port 25:

 
Sélectionnez

[...]
   If lsock <> -1 Then
       lname.sin_family = AF_INET ' famille "classique"
       lname.sin_port(1) = 25 \ 256 ' premire partie du port
       lname.sin_port(2) = 25 Mod 256 ' deuxime 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).

10-F. Le serveur sin_addr

Voici un paramtre bien compliqu.
sin_addr est un entier long, alors que l'adresse de notre hte est une chane de caractres (stmp.free.fr).

Voici les dclarations dont nous avons besoin:

dclarations 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 dplacer des zones de mmoire.

Dans le module modWinsock, nous crons une fonction qui permet de transformer le nom du serveur en une adresse dans un entier long pour l'lment sin_addr:
cette fonction doit tre crite aprs toutes les dclarations du module.


fonction addrfromhost ajouter au module modWinsock
Sélectionnez

' -------------------------------------------------------------
' Donnez un nom de serveur en entre: par exemple smtp.free.fr
' Retourne un entier long pour utilisation dans sin_addr
' WSAStartup doit tre excut 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
       ' Dplace le contenu mmoire  l'emplacement du pointeur lHost vers la structure lHostEnt
       RtlMoveMemory lHostEnt, ByVal lHost, LenB(lHostEnt)
       ' Prpare un tableau contenant les 4 parties de l'adresse
       ReDim lAddress(1 To lHostEnt.hLength) As Byte
       ' Rcupre le pointeur de l'adresse dans lHostAddress
       ' hAddrList est un pointeur vers un pointeur
       RtlMoveMemory lHostAddress, ByVal lHostEnt.hAddrList, lHostEnt.hLength
       ' Dplace 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


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

 
Sélectionnez

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

10-G. Rcapitulatif


Voici le code complet de connexion, utiliser avec le module modWinsock qui contient les dclarations:

 
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
   ' Cration 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 ' premire partie du port
       lname.sin_port(2) = 25 Mod 256 ' deuxime 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!" ' Bote 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 connecte au serveur.
Sinon, il faut regarder la valeur de Err.LastDllError pour connatre le code d'erreur.

Par exemple, une tentative de connexion sur le port 26 lve une erreur 10061: Connexion refuse.

10-H. Recevoir des donnes

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

dclaration 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 paramtres:
- hSocket est l'identifiant de la socket;
- buffer contiendra les donnes reues, il doit tre dimensionn de la taille de BufferLength au minimum;
- BufferLength est la taille des donnes recevoir;
- Flags est un paramtre que nous n'utiliserons pas.

Nous ne connaissons pas par avance la taille des donnes recevoir.
Pour faire simple, nous allons d'abord nous contenter de lire 1024 caractres, ce qui sera suffisant pour cette premire lecture.

Notez que nous avons dclar une fonction srecvstr qui est un appel la fonction recv mais avec un type de paramtre diffrent pour le buffer.
Cette fonction sera utile pour recevoir facilement des chanes de caractres.
La rception de chanes de caractres (String) avec la fonction recv ncessiterait une conversion des donnes avec StrConv.

rception de donnes
Sélectionnez

[...]
       ' Connexion
       lRet = Connect(lsock, lname, LenB(lname))
       If lRet = 0 Then
           ' Rception des donnes de connexion
           lStrToReceive = Space(1024)
           lRet = recvstr(lsock, lStrToReceive, Len(lStrToReceive), 0)
           If lRet > 0 Then
               lStrToReceive = Left(lStrToReceive, lRet)
               Debug.Print "Octets reus : " & lRet & vbCrLf & lStrToReceive
           End If
[...]


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

Voici le rsultat obtenu:

Octets reus: 37
220 smtp1-g21.free.fr ESMTP Postfix



noter:
- la fonction de rception est synchrone: c'est--dire que l'excution est interrompue tant que des donnes ne sont pas reues;
- il est utile de vrifier au pralable si le serveur a envoy des donnes, sinon on risque de bloquer l'excution;
- il est galement utile de vrifier que toutes les donnes ont t lues.

Nous tiendrons compte de ces dernires remarques dans le chapitre suivant sur l'envoi/rception avec timeout.

10-I. Envoyer des donnes

Une fois connect, on souhaite envoyer (et recevoir) des donnes.

Comme nous sommes connects un serveur SMTP, nous allons envoyer une commande EHLO qui est la premire commande excuter pour ce type de serveur.

L'envoi de donnes se fait l'aide de la fonction send.

dclaration 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 paramtres:
- hSocket est l'identifiant de la socket;
- buffer contient les donnes envoyer;
- BufferLength est la taille des donnes envoyer;
- Flags est un paramtre que nous n'utiliserons pas.

Elle retourne le nombre de caractres effectivement envoys.
En cas d'erreur d'envoi, la fonction retourne -1.

Il est possible que les donnes ne soient pas entirement envoyes en une fois.
Il faut alors envoyer le reste des donnes jusqu' ce que tout soit envoy.


Notez que nous avons dclar une fonction sendstr qui est un appel la fonction send mais avec un type de paramtre diffrent pour le buffer.
Cette fonction sera utile pour envoyer facilement des chanes de caractres.
L'envoi de chanes de caractres (String) avec la fonction send ncessiterait une conversion des donnes avec StrConv.

Une fois la commande envoye, nous lisons ensuite la rponse 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 donnes
           lRet = sendstr(lsock, lStrToSend, Len(lStrToSend), 0)
           Debug.Print "Octets envoys : " & lRet & " / " & Len(lStrToSend)
           ' Rception des donnes
           lStrToReceive = Space(1024)
           lRet = recvstr(lsock, lStrToReceive, Len(lStrToReceive), 0)
           If lRet > 0 Then
               lStrToReceive = Left(lStrToReceive, lRet)
               Debug.Print "Octets reus : " & lRet & vbCrLf & lStrToReceive
           End If
       Else
           Debug.Print "Erreur de connexion n " & Err.LastDllError
       End If
[...]

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


Si tout se passe bien, lRet doit contenir 19 qui est la taille des donnes envoyes.

noter:
- la fonction d'envoi est synchrone: c'est--dire que l'excution est interrompue tant que les donnes ne sont pas envoyes;
- il est utile de vrifier avant envoi si le serveur est prt recevoir des donnes, sinon on risque de bloquer l'excution;
- il est galement utile de vrifier que toutes les donnes ont t envoyes.

Nous tiendrons compte de ces dernires remarques dans le chapitre suivant sur l'envoi/rception avec timeout.

Voici le code complet d'envoi/rception de donnes, utiliser avec le module modWinsock qui contient les dclarations:

 
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
   ' Cration 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 ' premire partie du port
       lname.sin_port(2) = 25 Mod 256 ' deuxime partie du port
       lname.sin_addr = addrfromhost("smtp.free.fr") ' adresse du serveur
       ' Connexion
       lRet = Connect(lsock, lname, LenB(lname))
       If lRet = 0 Then
           ' Rception des donnes de connexion
           lStrToReceive = Space(1024)
           lRet = recvstr(lsock, lStrToReceive, Len(lStrToReceive), 0)
           If lRet > 0 Then
               lStrToReceive = Left(lStrToReceive, lRet)
               Debug.Print "Octets reus : " & lRet & vbCrLf & lStrToReceive
           End If
           ' Envoi d'une commande EHLO
           lStrToSend = "EHLO smtp.free.fr" & vbCrLf
           ' Envoi des donnes
           lRet = sendstr(lsock, lStrToSend, Len(lStrToSend), 0)
           Debug.Print "Octets envoys : " & lRet & " / " & Len(lStrToSend)
           ' Rception des donnes
           lStrToReceive = Space(1024)
           lRet = recvstr(lsock, lStrToReceive, Len(lStrToReceive), 0)
           If lRet > 0 Then
               lStrToReceive = Left(lStrToReceive, lRet)
               Debug.Print "Octets reus : " & lRet & vbCrLf & lStrToReceive
           End If
       Else
           MsgBox "Erreur de connexion n " & Err.LastDllError
       End If
       closesocket lsock
   End If
   WSACleanup
End If
End Function


Si vous excutez ce code derrire un proxy, vous obtiendrez certainement une erreur (dans mon cas: erreur 10054 sur rception de donnes).

Sinon, voici le rsultat obtenu:

Octets reus: 37
220 smtp1-g21.free.fr ESMTP Postfix

Octets envoys: 19 / 19
Octets reus: 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.

10-J. Envoyer et recevoir des donnes avec Timeout

Dans les deux chapitres prcdents nous avons envoy et reu des donnes de manire simple.
Pour couvrir tous les cas possibles, il est utile de crer des fonctions d'envoi et de rception qui font quelques vrifications et s'assurent que les donnes ont bien t envoyes ou reues en totalit.
De plus, programmer un timeout est presque indispensable pour ne pas se retrouver bloqu en attente d'envoi ou de rception.

La fonction qui nous permet de vrifier si la socket est prte envoyer ou recevoir est la fonction select:

dclaration 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 rserv de VBA, j'ai appel la fonction wselect.

Les types FD_SET et TIMEVAL sont utiliss par cette fonction.

On a cinq paramtres en entre:
- Reserved est inutilis;
- ReadFds est une structure de type FD_SET dfinissant les sockets vrifier pour lecture (=rception);
- WriteFds est une structure de type FD_SET dfinissant les sockets vrifier pour criture (=envoi);
- ExceptFds est une structure de type FD_SET dfinissant les sockets vrifier pour statut en erreur;
- timeout est une structure de type TIMEVAL dfinissant le timeout.

Chaque structure FD_SET doit tre remplie ainsi:
- fd_count est le nombre de sockets vrifier;
- 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 cumuls.

La fonction renvoie le nombre de sockets prtes.
Si le temps dfini est coul, la fonction renvoie 0.
S'il y a une erreur, la fonction renvoie -1.

Voici deux fonctions pour envoyer et recevoir des donnes de type String avec un dlai en secondes (10 par dfaut):

fonctions d'envoi et rception dans modWinsock
Sélectionnez

' -----------------------------------------------------------------------------
' Rception de donnes (String) sur une socket sock avec timeout en secondes
' -----------------------------------------------------------------------------
Public Function RecvStrTO(sock As Long, 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
' dlai en secondes
lti.tv_sec = timeout
' une socket  vrifier
lfdr.fd_count = 1
' la socket passe en paramtre
lfdr.fd_array(1) = sock
' la socket est-elle prte?
lRet = wselect(0, lfdr, lfdw, lfde, lti)
' Si pas d'erreur et dlai non dpass
If lRet > 0 Then
   ' Boucle tant qu'il y a des donnes
   Do
       ' Si socket prte
       If lfdr.fd_count = 1 Then
           ' Rception
           lbuffer = Space(1024)
           lRet = recvstr(sock, lbuffer, 1024, 0)
           ' Ajoute les donnes reues au rsultat
           If lRet > 0 Then
               lbuffer = Left(lbuffer, lRet)
               RecvStrTO = RecvStrTO & lbuffer
           ElseIf lRet <= 0 Then
               Exit Do
           End If
       End If
       ' Vrifie s'il y a encore des donnes  recevoir (avec dlai  zro)
       lti.tv_sec = 0
       lRet = wselect(0, lfdr, lfdw, lfde, lti)
       ' Si erreur ou dlai dpass
       If lRet <= 0 Then Exit Do
   Loop
End If
End Function

' -----------------------------------------------------------------------------
' Envoi de donnes (String) sur une socket sock avec timeout en secondes
' Cette fonction renvoie True si l'envoi est correct
' -----------------------------------------------------------------------------
Public Function SendStrTO(sock As Long, 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
' dlai en secondes
lti.tv_sec = timeout
' une socket  vrifier
lfdw.fd_count = 1
' la socket passe en paramtre
lfdw.fd_array(1) = sock
' la socket est-elle prte?
lRet = wselect(0, lfdr, lfdw, lfde, lti)
' Si pas d'erreur et dlai non dpass
If lRet > 0 Then
   ' Boucle tant qu'il y a des donnes  envoyer
   Do
       ' Si socket prte
       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 modifie 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
   ' Cration 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 ' premire partie du port
       lname.sin_port(2) = 25 Mod 256 ' deuxime 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 envoye: " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus: " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
       Else
           Debug.Print "Erreur de connexion n " & Err.LastDllError
       End If
       closesocket lsock
   End If
   WSACleanup
End If
End Function


Ces deux fonctions vont nous tre utiles pour la suite.

10-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-cls SMTP Telnet.

10-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
   ' Cration 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 ' premire partie du port
       lname.sin_port(2) = 25 Mod 256 ' deuxime partie du port
       lname.sin_addr = addrfromhost("smtp.free.fr") ' adresse du serveur
       ' Connexion
       lRet = Connect(lsock, lname, LenB(lname))
       If lRet = 0 Then
           ' Rception des donnes de connexion
           lStrToReceive = RecvStrTO(lsock)
           Debug.Print "Octets reus: " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           ' Envoi d'une commande EHLO
           lStrToSend = "EHLO smtp.free.fr" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye: " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & 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 envoye: " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus: " & 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 envoye: " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Dbut des donnes
           lStrToSend = "DATA" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & 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 envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & 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 envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Fin du contenu => dclenche l'envoi du mail
           lStrToSend = "." & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Quitte le serveur
           lStrToSend = "quit" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
       Else
           Debug.Print "Erreur de connexion n " & Err.LastDllError
       End If
       closesocket lsock
   End If
   WSACleanup
End If
End Function


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

Voici le rsultat obtenu dans la fentre Excution :

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

On peut bien sr exploiter les donnes reues pour lire les codes retour et ragir en cas d'erreur.

Notez que certaines commandes (celles qui envoient les donnes du mail, aprs la commande DATA) ne donnent pas lieu une rponse du serveur.
On peut retirer les lectures d'information inutiles qui ralentissent le traitement en attente du timeout.

Notez galement que sur le mail reu, l'accent n'est pas correctement restitu.

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

 
Sélectionnez

           ' En-tte des donnes
           lStrToSend = "Content-Type: text/plain; charset=""iso-8859-1""" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
           End If


On dfinit ici un contenu texte brut (text/plain) avec un codage (charset) iso-8859-1.
Les accents sont alors correctement restitus.

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

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

 
Sélectionnez

            [...]
           ' En-tte des donnes
           lStrToSend = "Content-Type: text/HTML; charset=""iso-8859-1""" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & 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 envoye : " & vbCrLf & lStrToSend
           End If
           [...]

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

10-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 codes en Base64.
Nous allons crer une fonction de codage en Base64 grce la librairie crypt32.dll apparue avec Windows XP.

dclaration 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
 ' Rcupre la taille ncessaire
 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 scurisation des informations.

Le codage en Base64 avec la fonction CryptBinaryToString ajoute automatiquement un saut de ligne (vbCrLf) en fin de chane.
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
   ' Cration 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 ' premire partie du port
       lname.sin_port(2) = 587 Mod 256 ' deuxime partie du port
       lname.sin_addr = addrfromhost("smtp.live.com") ' adresse du serveur
       ' Connexion
       lRet = Connect(lsock, lname, LenB(lname))
       If lRet = 0 Then
           ' Rception des donnes de  Connexion
           lStrToReceive = RecvStrTO(lsock)
           Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           ' Envoi d'une commande EHLO
           lStrToSend = "EHLO smtp.live.com" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & 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 envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & 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 envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Envoi du mot de passe
           lStrToSend = Base64("MonMotDePasse")
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & 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 envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsoc)
               Debug.Print "Octets reus : " & 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 envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Dbut des donnes
           lStrToSend = "DATA" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & 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 envoye : " & 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 envoye : " & vbCrLf & lStrToSend
           End If
           ' Fin du contenu => dclenche l'envoi du mail
           lStrToSend = "." & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Quitte le serveur
           lStrToSend = "quit" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
       Else
           Debug.Print "Erreur de connexion n " & Err.LastDllError
       End If
       closesocket lsock
   End If
   WSACleanup
End If
End Function

10-K-3. Envoi de pices jointes

L'envoi de pice jointe se fait avec un format trs prcis.
Le contenu du mail doit tre crit dans un lment multipart/mixed.
La construction des donnes ressemble fortement ce qu'on a vu dans le chapitre Passage de paramtres multiples complexes.

Une pice jointe s'envoie gnralement 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
   ' Cration 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 ' premire partie du port
       lname.sin_port(2) = 587 Mod 256 ' deuxime partie du port
       lname.sin_addr = addrfromhost("smtp.live.com") ' adresse du serveur
       ' Connexion
       lret = Connect(lsock, lname, LenB(lname))
       If lret = 0 Then
           ' Rception des donnes de connexion
           lStrToReceive = RecvStrTO(lsock)
           Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           ' Envoi d'une commande EHLO
           lStrToSend = "EHLO smtp.live.com" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & 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 envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & 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 envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Envoi du mot de passe
           lStrToSend = Base64("monMotDePasse")
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & 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 envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & 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 envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Dbut des donnes
           lStrToSend = "DATA" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & 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 envoye : " & vbCrLf & lStrToSend
           End If
           ' Contenu du mail
           lStrToSend = "MIME-Version: 1.0" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
           End If
           lStrToSend = "Content-type: multipart/mixed;boundary=""ax0rt1232"")" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
           End If
           lStrToSend = vbCrLf & "--ax0rt1232" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
           End If
           lStrToSend = "Content-type: text/plain" & vbCrLf & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & 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 envoye : " & vbCrLf & lStrToSend
           End If
           lStrToSend = "--ax0rt1232" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
           End If
           lStrToSend = "Content-Type: application/text; name=""myfile.txt""" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
           End If
           lStrToSend = "Content-Transfer-Encoding: base64" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
           End If
           lStrToSend = "Content-Disposition: attachment; filename=""myfile.txt""" & vbCrLf & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
           End If
           lStrToSend = Base64("Contenu du fichier")
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
           End If
           lStrToSend = "--ax0rt1232--" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
           End If
           ' Fin du contenu => dclenche l'envoi du mail
           lStrToSend = "." & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Quitte le serveur
           lStrToSend = "quit" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
       Else
           Debug.Print "Erreur de connexion n " & Err.LastDllError
       End If
       closesocket lsock
   End If
   WSACleanup
End If
End Function

10-L. Gestion d'un serveur FTP

Un autre serveur bien connu est le serveur FTP.
Les sockets vont nous permettre de raliser (au prix de quelques efforts) toutes les oprations habituelles d'un client FTP.
On pourra mme 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 diffremment 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 envoyes.

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 prcdent.

10-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 ralis prcdemment 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
   ' Cration d'une socket
   lsock = socket(AF_INET, SOCK_STREAM, 0)
   If lsock <> -1 Then
       lname.sin_family = AF_INET ' famille "classique"
       ' Le port est gnralement 21 pour du FTP
       lname.sin_port(1) = 21 \ 256 ' premire partie du port
       lname.sin_port(2) = 21 Mod 256 ' deuxime partie du port
       lname.sin_addr = addrfromhost("MonSiteFTP.com") ' adresse du serveur
       ' Connexion
       If Connect(lsock, lname, LenB(lname)) = 0 Then
           ' Rception des donnes de connexion
           lStrToReceive = RecvStrTO(lsock)
           Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           ' Envoi du nom d'utilisateur
           lStrToSend = "USER monUtilisateur" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Envoi du mot de passe
           lStrToSend = "PASS monMotDePasse" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock) 
                Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
               ' Deuxime rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Quitte le serveur
           lStrToSend = "quit" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
       Else
           Debug.Print "Erreur de connexion n " & Err.LastDllError
       End If
       closesocket lsock
   End If
   WSACleanup
End If
End Function


Et voici le rsultat obtenu dans la fentre Excution :

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

Commande envoye :
USER monUtilisateur

Octets reus : 40
331 User monUtilisateur okay, need password.

Commande envoye :
PASS monMotDePasse

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

Octets reus : 38
230-
230 Restricted user logged in.

Commande envoye :
quit

Octets reus : 14
221 Goodbye.


noter : je fais deux lectures de donnes aprs l'envoi du mot de passe car je ne rcupre pas tout la premire fois.
Sans doute qu'il y a deux envois de la part du serveur.


10-L-2. Connexion un serveur avec proxy

 

Si vous tes derrire un proxy, les commandes envoyer dpendent du type de proxy.
Dans FileZilla, vous pouvez trouver les diffrents type de proxy dans le menu : Edition => Paramtres => Paramtres 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 prcdente sans proxy sauf que :
- la socket est connecte 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
   ' Cration d'une socket
   lsock = socket(AF_INET, SOCK_STREAM, 0)
   If lsock <> -1 Then
       lname.sin_family = AF_INET ' famille "classique"
       ' Le port est gnralement 21 pour du FTP
       lname.sin_port(1) = 21 \ 256 ' premire partie du port
       lname.sin_port(2) = 21 Mod 256 ' deuxime partie du port
       lname.sin_addr = addrfromhost("monproxyftp") ' adresse du serveur
       ' Connexion
       If Connect(lsock, lname, LenB(lname)) = 0 Then
           ' Rception des donnes de connexion
           lStrToReceive = RecvStrTO(lsock)
           Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           ' Envoi du nom d'utilisateur
           lStrToSend = "USER monUtilisateur@MonSiteFTP.com" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Envoi du mot de passe
           lStrToSend = "PASS monMotDePasse" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Quitte le serveur
           lStrToSend = "quit" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
       Else
           Debug.Print "Erreur de connexion n " & Err.LastDllError
       End If
       closesocket lsock
   End If
   WSACleanup
End If
End Function


Et voici le rsultat obtenu dans la fentre Excution :

Octets reus : 27
220 Blue Coat FTP Service

Commande envoye :
USER monUtilisateur@MonSiteFTP.comm

Octets reus : 40
331 User monUtilisateur okay, need password.

Commande envoye :
PASS monMotDePasse

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

Commande envoye :
quit

Octets reus : 41
221 Service closing control connection.

10-L-3. Liste des commandes FTP


Les commandes FTP sont normalises et consultables ici : FILE TRANSFER PROTOCOL (FTP).

Une liste simplifie est sur Wikipedia : List of FTP commands.

Vous pouvez galement faire une opration avec FileZilla et regarder dans le journal des messages quelle est la commande envoye.

10-L-4. Rcuprer la liste des dossiers et fichiers (LIST)


Reprenons le code prcdent (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'aperoit que celui-ci envoie les commandes suivantes :
- TYPE A : passage en mode ASCII (pour du texte car la liste est envoye en texte;
- PASV : passage en mode passif (le serveur envoie l'adresse o se connecter pour recevoir les donnes;
- 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 dfini par la commande PORT.
Pour plus d'information sur la diffrence 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 envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Mode passif
           lStrToSend = "PASV" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Demande de la liste
           lStrToSend = "LIST" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
[...]


Et voici le rsultat obtenu pour ces trois commandes dans la fentre Excution :

Commande envoye :
TYPE A

Octets reus : 16
200 Type okay.

Commande envoye :
PASV

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

Commande envoye :
LIST

Octets reus : 0


Pas de liste de fichiers en vue...
On obtient en fait, en retour de la commande PASV, l'adresse o se connecter pour rcuprer 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 aprs la commande PASV.
La lecture des donnes se fait aprs l'envoi de la commande LIST.
Le serveur attend notre connexion la socket de donnes, c'est pour cela que la commande LIST n'a pas retourn d'information.

Pour rcuprer 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 rcupration 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
   ' Cration d'une socket
   lsock = socket(AF_INET, SOCK_STREAM, 0)
   If lsock <> -1 Then
       lname.sin_family = AF_INET ' famille "classique"
       ' Le port est gnralement 21 pour du FTP
       lname.sin_port(1) = 21 \ 256 ' premire partie du port
       lname.sin_port(2) = 21 Mod 256 ' deuxime partie du port
       lname.sin_addr = addrfromhost("monserveurftp") ' adresse du serveur
       ' Connexion
       If Connect(lsock, lname, LenB(lname)) = 0 Then
           ' Rception des donnes de connexion
           lStrToReceive = RecvStrTO(lsock)
           Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           ' Envoi du nom d'utilisateur
           lStrToSend = "USER monUtilisateur" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Envoi du mot de passe
           lStrToSend = "PASS monMotDePasse" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
               ' Deuxime rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Type ASCII
           lStrToSend = "TYPE A" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Mode passif
           lStrToSend = "PASV" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Cration et connexion d'une socket de donnes
           Dim lsockdata As Long ' socket de donnes
           Dim lnamedata As SOCKADDR ' adresse de la socket de donnes
           lsockdata = socket(AF_INET, SOCK_STREAM, 0)
           If lsockdata <> -1 Then
               Dim lSplit As Variant ' tableau contenant les donnes entre parenthses
               Dim lPos1 As Long, lPos2 As Long ' position des parenthses
               lPos1 = InStr(lStrToReceive, "(") ' parenthse ouvrante
               lPos2 = InStr(lPos1, lStrToReceive, ")") ' parenthse fermante
               ' rcupre les informations d'adresse dans un tableau (indice base 0 par dfaut)
               lSplit = Split(Mid(lStrToReceive, lPos1 + 1, lPos2 - lPos1 - 1), ",")
               lnamedata.sin_family = AF_INET ' famille "classique"
               ' Le port est gnralement 21 pour du FTP
               lnamedata.sin_port(1) = lSplit(4) ' premire partie du port
               lnamedata.sin_port(2) = lSplit(5) ' deuxime 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 russie  la socket de donnes" & vbCrLf
               End If
           End If
           ' Demande de la liste
           lStrToSend = "LIST" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Rcupre la liste sur la socket de donnes
           lStrToReceive = RecvStrTO(lsockdata)
           Debug.Print "Liste : " & vbCrLf & lStrToReceive
           ' Ferme la socket de donnes
           closesocket lsockdata
           ' Quitte le serveur
           lStrToSend = "quit" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
       Else
           Debug.Print "Erreur de connexion n " & Err.LastDllError
       End If
       closesocket lsock
   End If
   WSACleanup
End If
End Function


Et voici le rsultat obtenu dans la fentre Excution :

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

Commande envoye :
USER monUtilisateur

Octets reus : 40
331 User monUtilisateur okay, need password.

Commande envoye :
PASS monMotDePasse

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

Octets reus : 38
230-
230 Restricted user logged in.

Commande envoye :
TYPE A

Octets reus : 16
200 Type okay.

Commande envoye :
PASV

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

connexion russie la socket de donnes

Commande envoye :
LIST

Octets reus : 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 reus : 24
226 Listing completed.

Commande envoye :
quit

Octets reus : 14
221 Goodbye.


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

10-L-5. Tlcharger un fichier (RETR)


Le tlchargement d'un fichier se fait suivant le mme principe que pour la rcupration 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 systme d'exploitation.
Comme nous avons cr une fonction RecvStrTO ddie la rception de texte, nous ne pouvons pas l'utiliser pour un contenu binaire de fichier.
De plus, un fichier peut tre trs volumineux ; il n'est pas concevable de rcuprer tout le fichier en mmoire avant de l'crire sur le disque.

Voici une fonction ajouter au module modWinsock :

 
Sélectionnez

' -----------------------------------------------------------------------------
' Rception de donnes binaires sur une socket sock avec timeout en secondes
' -----------------------------------------------------------------------------
Public Function RecvBinTO(sock As Long, 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
' dlai en secondes
lti.tv_sec = timeout
' une socket  vrifier
lfdr.fd_count = 1
' la socket passe en paramtre
lfdr.fd_array(1) = sock
' la socket est-elle prte?
lret = wselect(0, lfdr, lfdw, lfde, lti)
' Si pas d'erreur et dlai non dpass
If lret > 0 Then
   ' Si socket prte
   If lfdr.fd_count = 1 Then
       ' Buffer de rception
       ReDim lbuffer(1 To nbRead)
       ' Rception binaire
       lret = recv(sock, lbuffer(1), nbRead, 0)
       ' Redimensionne le buffer en fonction des donnes reues
       If lret > 0 Then
           ReDim Preserve lbuffer(1 To lret)
           nbRead = lret
       ElseIf lret <= 0 Then
           Erase lbuffer
           nbRead = 0
       End If
   End If
End If
RecvBinTO = lbuffer
End Function


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

Voici un exemple de tlchargement 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
   ' Cration d'une socket
   lsock = socket(AF_INET, SOCK_STREAM, 0)
   If lsock <> -1 Then
       lname.sin_family = AF_INET ' famille "classique"
       ' Le port est gnralement 21 pour du FTP
       lname.sin_port(1) = 21 \ 256 ' premire partie du port
       lname.sin_port(2) = 21 Mod 256 ' deuxime partie du port
       lname.sin_addr = addrfromhost("monserveurftp") ' adresse du serveur
       ' Connexion
       If Connect(lsock, lname, LenB(lname)) = 0 Then
           ' Rception des donnes de connexion
           lStrToReceive = RecvStrTO(lsock)
           Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           ' Envoi du nom d'utilisateur
           lStrToSend = "USER monUtilisateur" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Envoi du mot de passe
           lStrToSend = "PASS monMotDePasse" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Type Binaire
           lStrToSend = "TYPE I" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Mode passif
           lStrToSend = "PASV" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
           ' Cration et connexion d'une socket de donnes
           Dim lsockdata As Long ' socket de donnes
           Dim lnamedata As SOCKADDR ' adresse de la socket de donnes
           lsockdata = socket(AF_INET, SOCK_STREAM, 0)
           If lsockdata <> -1 Then
               Dim lSplit As Variant ' tableau contenant les donnes entre parenthses
               Dim lPos1 As Long, lPos2 As Long ' position des parenthses
               lPos1 = InStr(lStrToReceive, "(") ' parenthse ouvrante
               lPos2 = InStr(lPos1, lStrToReceive, ")") ' parenthse fermante
               ' rcupre les informations d'adresse dans un tableau (indice base 0 par dfaut)
               lSplit = Split(Mid(lStrToReceive, lPos1 + 1, lPos2 - lPos1 - 1), ",")
               lnamedata.sin_family = AF_INET ' famille "classique"
               ' Le port est gnralement 21 pour du FTP
               lnamedata.sin_port(1) = lSplit(4) ' premire partie du port
               lnamedata.sin_port(2) = lSplit(5) ' deuxime 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 russie  la socket de donnes" & vbCrLf
               End If
           End If
           ' Demande du fichier monfichier.zip
           lStrToSend = "RETR monfichier.zip" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception du retour de la commande
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
               ' Rception des donnes 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 dj
               ' 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
                   'rception de donnes
                   lbuffer = RecvBinTO(lsockdata, lNbRead, 2)
                   ' taille totale
                   lTotalByte = lTotalByte + lNbRead
                   ' si plus de donnes  recevoir
                   If lNbRead = 0 Then Exit Do
                   ' crit les donnes dans le fichier
                   Put #f, , lbuffer
               Loop
               Close f ' ferme le fichier
               Debug.Print "Octets reus dans le fichier: " & lTotalByte & vbCrLf
           End If
           ' Ferme la socket de donnes
           closesocket lsockdata
           ' Quitte le serveur
           lStrToSend = "quit" & vbCrLf
           If SendStrTO(lsock, lStrToSend, 2) Then
               Debug.Print "Commande envoye : " & vbCrLf & lStrToSend
               ' Rception des donnes
               lStrToReceive = RecvStrTO(lsock)
               Debug.Print "Octets reus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
           End If
       Else
           Debug.Print "Erreur de connexion n " & Err.LastDllError
       End If
       closesocket lsock
   End If
   WSACleanup
End If
End Function


Avec les sockets, on rcupre un buffer en mmoire contenant les donnes du fichier.
On crit le fichier sur le disque avec les fonctions intgres de VBA (open, put...).

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


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

10-M. Cration d'un serveur

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

Nous allons maintenant dvelopper 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.

dclaration 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 dfinit 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 (prte 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 prcdentes, il faut utiliser inet_ntoa qui est un peu plus complexe.

Voici un exemple de module pour un serveur (trs 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

' Vrifie si un client a envoy des donnes
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  zro seconde
ti.tv_sec = 0
' Fait une copie de la structure contenant les clients (fdr est modifie par wselect)
LSet fdr = ClientSocks
If wselect(0, fdr, fdw, fde, ti) > 0 Then
   ' Pour chaque client ayant envoy des donnes
   For cpt = 1 To fdr.fd_count
       ' Lit les donnes
       sStrToRecv = RecvStrTO(fdr.fd_array(cpt), 0)
       ' Ecrit les donnes reues dans la fentre Excution
       If sStrToRecv <> "" Then Debug.Print sStrToRecv
   Next
End If
' Relance cette procdure dans une seconde
If ServerSock <> 0 Then Application.OnTime DateAdd("s", 1, Now), "ServerCheckRecv"
End Function

' Vrifie 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  zro seconde
ti.tv_sec = 0
fdr.fd_count = 1
' Vrifie 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 connecte
   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
   ' Rcupre 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 procdure 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
   ' Cration 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 ' premire partie du port
       lname.sin_port(2) = 1025 Mod 256 ' deuxime 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
               ' Excute les fonctions d'acceptation et de rception 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

' Arrte 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 excutes priodiquement toutes les secondes grce l'instruction OnTime.
Sous Access, on pourrait utiliser la minuterie d'un formulaire.

Dmarrez le serveur avec RunServer et arrtez-le avec StopServeur.

Pour cet exemple, j'ai spcifi l'adresse 127.0.0.1 qui est la boucle locale du PC.
C'est--dire que seul le PC sur lequel s'excute le serveur peut communiquer avec lui.
Vous pouvez mettre l'adresse IP de la carte rseau du PC la place.
Le client devra alors utiliser cette adresse galement.
Remarque : mettez l'lment sin_addr zro (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 dj tre utilis.
On peut mettre le port 0 pour que la fonction bind recherche elle-mme un port libre.
La fonction getsockname permet alors de retrouver le port utilis : le client devra spcifier ce port la connexion.

Le serveur seul ne fait rien, il faut dvelopper une partie client.
Ce client devra tre un autre fichier Excel excut dans une application distincte de celle du serveur.
Crez 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
   ' Cration 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 envoye par le serveur
       lstrToRecv = RecvStrTO(lClientSock)
       Debug.Print "Reu : " & lstrToRecv
   End If
   ' Ferme la socket
   closesocket lClientSock
   ' Purge Winsock
   WSACleanup
End If
End Function


Ce client est trs simple : il se connecte au serveur et rcupre l'information de connexion.
Il se dconnecte 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, excutez RunServeur sur une application, et RunClient sur l'autre.
Excutez ensuite StopServeur pour ne pas laisser tourner le serveur inutilement.

Voici le rsultat obtenu ct client :

Port socket Client: 4762
Reu : 127.0.0.1:4762 Connected OK


Avec getsockname ct client, on a rcupr le port de la socket client.
Ce port est diffrent de celui du serveur : chaque client a besoin d'un port.

L'information reue provient du serveur :
Celui-ci rcupre l'adresse IP et le port du client grce la fonction WSAAddressToString.

Ce client-serveur assez simple permet, je l'espre, de comprendre les bases pour dvelopper des applications plus complexes.
Il est possible de connecter plusieurs clients un serveur distant et de programmer un chat par exemple.

10-N. Module modWinsock

Voici le code du module modWinsock utilis dans les chapitres prcdents :

Module modWinsock
Sélectionnez

Option Explicit

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" Alias "connect" (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)

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

Public Type HOSTENT
 hName     As Long
 hAliases  As Long
 hAddrType As Integer
 hLength   As Integer
 hAddrList As Long
End Type

Public 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

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

Public Const AF_INET = 2
Public Const SOCK_STREAM = 1
Public Const CRYPT_STRING_BASE64 = 1

' -------------------------------------------------------------
' Donnez un nom de serveur en entre: par exemple smtp.free.fr
' Retourne un entier long pour utilisation dans sin_addr
' WSAStartup doit tre excut 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
       ' Dplace le contenu mmoire  l'emplacement du pointeur lHost vers la structure lHostEnt
       RtlMoveMemory lHostEnt, ByVal lhost, LenB(lHostEnt)
       ' Prpare un tableau contenant les 4 parties de l'adresse
       ReDim lAddress(1 To lHostEnt.hLength) As Byte
       ' Rcupre le pointeur de l'adresse dans lHostAddress
       ' hAddrList est un pointeur vers un pointeur
       RtlMoveMemory lHostAddress, ByVal lHostEnt.hAddrList, lHostEnt.hLength
       ' Dplace 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

' -----------------------------------------------------------------------------
' Rception de donnes (String) sur une socket sock avec timeout en secondes
' -----------------------------------------------------------------------------
Public Function RecvStrTO(sock As Long, 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
' dlai en secondes
lti.tv_sec = timeout
' une socket  vrifier
lfdr.fd_count = 1
' la socket passe en paramtre
lfdr.fd_array(1) = sock
' la socket est-elle prte?
lret = wselect(0, lfdr, lfdw, lfde, lti)
' Si pas d'erreur et dlai non dpass
If lret > 0 Then
   ' Boucle tant qu'il y a des donnes
   Do
       ' Si socket prte
       If lfdr.fd_count = 1 Then
           ' Rception
           lbuffer = Space(1024)
           lret = recvstr(sock, lbuffer, 1024, 0)
           ' Ajoute les donnes reues au rsultat
           If lret > 0 Then
               lbuffer = Left(lbuffer, lret)
               RecvStrTO = RecvStrTO & lbuffer
           ElseIf lret <= 0 Then
               Exit Do
           End If
       End If
       ' Vrifie s'il y a encore des donnes  recevoir (avec dlai  zro)
       lti.tv_sec = 0
       lret = wselect(0, lfdr, lfdw, lfde, lti)
       ' Si erreur ou dlai dpass
       If lret <= 0 Then Exit Do
   Loop
End If
End Function

' -----------------------------------------------------------------------------
' Envoi de donnes (String) sur une socket sock avec timeout en secondes
' Cette fonction renvoie True si l'envoi est correct
' -----------------------------------------------------------------------------
Public Function SendStrTO(sock As Long, 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
' dlai en secondes
lti.tv_sec = timeout
' une socket  vrifier
lfdw.fd_count = 1
' la socket passe en paramtre
lfdw.fd_array(1) = sock
' la socket est-elle prte?
lret = wselect(0, lfdr, lfdw, lfde, lti)
' Si pas d'erreur et dlai non dpass
If lret > 0 Then
   ' Boucle tant qu'il y a des donnes  envoyer
   Do
       ' Si socket prte
       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
 ' Rcupre la taille ncessaire
 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

' -----------------------------------------------------------------------------
' Rception de donnes binaires sur une socket sock avec timeout en secondes
' -----------------------------------------------------------------------------
Public Function RecvBinTO(sock As Long, 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
' dlai en secondes
lti.tv_sec = timeout
' une socket  vrifier
lfdr.fd_count = 1
' la socket passe en paramtre
lfdr.fd_array(1) = sock
' la socket est-elle prte?
lret = wselect(0, lfdr, lfdw, lfde, lti)
' Si pas d'erreur et dlai non dpass
If lret > 0 Then
   ' Si socket prte
   If lfdr.fd_count = 1 Then
       ' Buffer de rception
       ReDim lbuffer(1 To nbRead)
       ' Rception binaire
       lret = recv(sock, lbuffer(1), nbRead, 0)
       ' Redimensionne le buffer en fonction des donnes reues
       If lret > 0 Then
           ReDim Preserve lbuffer(1 To lret)
           nbRead = lret
       ElseIf lret <= 0 Then
           Erase lbuffer
           nbRead = 0
       End If
   End If
End If
RecvBinTO = lbuffer
End Function

10-O. Compatibilit avec Office 64 bits

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

Si la demande est forte, il se peut que j'envisage de faire un module compatible 64 bits. ;o)

10-P. Connexion SSL scurise

Certains serveurs requirent une connexion SSL scurise.

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

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

10-Q. Conclusion Winsock

Nous avons vu que Winsock permet de dvelopper des dialogues client-serveur avancs, mais au prix d'efforts de programmation non ngligeables.

Les codes donns 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 rponse en une seule fonction;
- et un module de classe pour grer 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 matrise pas toutes.


prcdentsommairesuivant

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 ni 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.