X. API Winsock▲
Commençons par une petite traduction : l'élément de base de Winsock est la socket.
En anglais socket signifie prise de courant (celle qui est au mur) ou douille.
Ne pas confondre avec sock qui signifie chaussette.
Comme WinInet (chapitre précédent), Winsock est une librairie dont nous devons déclarer les fonctions, types et constantes utilisés.
Il est possible que vous ayez à votre disposition le contrôle ActiveX Winsock.
Celui est installé avec VB6 et avec certaines versions d'Office.
Pour l'utilisation de ce contrôle, je vous renvoie vers des tutoriels écrits pour VB6 mais dont le code est similaire en VBA :
- VB et les réseaux ;
- Winsock (client mail).
Dans la suite de cet article, nous allons utiliser l'API.
La liste des fonctions de cette API est sur MSDN en anglais : Winsock Reference.
Il existe deux librairies Winsock : wsock32.dll et ws2_32.dll.
ws2_32.dll est la version 2 de Winsock (qui permet également de cibler une version 1 de Winsock).
wsock32.dll est l'ancienne librairie conservée pour compatibilité.
X-A. Module VBA modWinsock▲
Nous allons avoir besoin de déclarer les fonctions, types et constantes de l'API.
De plus, il sera utile de créer quelques fonctions personnalisées pour effectuer des actions répétitives.
Créons donc un module VBA que nous appelons modWinSock.
Les fonctions utilisées dans les chapitres suivants seront ajoutées à ce module.
En fin de ce chapitre Winsock, vous trouverez le code de ce module.
X-B. Initialiser Winsock▲
Avant tout appel à une fonction Winsock, il est indispensable de lancer une fonction d'initialisation WSAStartup.
Si Winsock n'est plus utile, il faut appeler la fonction WSACleanup.
Public Declare Function WSAStartup Lib "ws2_32.dll" (ByVal wVersionRequested As Integer, ByRef lpWSAData As WSADATA) As Long
Public Declare Function WSACleanup Lib "ws2_32.dll" () As Long
Public Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription As String * 256
szSystemStatus As String * 128
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As Long
End Type
WSAStartup accepte deux paramètres :
- wVersionRequested est la version minimale requise par le programme ;
- lpWSAData est une structure de type WSADATA qui reçoit des informations lors de l'initialisation.
En retour on obtient 0 si l'initialisation est correcte.
La version requise est un entier long créé ainsi :
Pour une version m.n :m + n * 256.
Pour cibler une version 1.1 (suffisante dans de nombreux cas) : 1 + 1 * 256 = 257.
Par exemple :
Function tuto1()
Dim lData As WSADATA
If WSAStartup(257, lData) = 0 Then
' le code suivant est à ajouter ici
WSACleanup
End If
End Function
Cette fonction tuto1 est à écrire dans un nouveau module pour ne pas polluer le module modWinsock.
Après exécution de WSAStartup, la structure lData contient :
- une description szDescription : "WinSock 2.0" par exemple ;
- un statut szSystemStatus : "Running" par exemple ;
- la version demandée wVersion : 257 pour notre exemple ;
- la version maximale supportée wHighVersion : 514 par exemple.
Pour retrouver la version à partir d'un entier long :
- m = version mod 256
- n = version \ 256
Pour 514 => version 2.2.
En cas d'erreur WSAStartup renvoie un code d'erreur.
Pour les autres fonctions, il faut lire la valeur de Err.LastDllError.
Les codes d'erreur sont détaillés ici : Windows Sockets Error Codes.
X-C. Créer une socket▲
La socket est l'élément de base à toute connexion.
Pour la créer, nous utilisons la fonction socket.
Public Declare Function socket Lib "ws2_32.dll" (ByVal AddressFamily As Long, ByVal SocketType As Long, ByVal Protocol As Long) As Long
Public Declare Function closesocket Lib "ws2_32.dll" (ByVal hSocket As Long) As Long
Public Const AF_INET = 2
Public Const SOCK_STREAM = 1
Deux constantes sont également utiles :
- AF_INET qui définit la famille d'adresse ;
- SOCK_STREAM qui définit le type de socket (TCP).
Ce type de socket est le plus simple et le plus courant : c'est le seul qu'on abordera dans cet article.
Pour plus d'information sur les familles d'adresses et types de sockets : socket Function.
On a également déclaré la fonction closesocket pour fermer la socket après utilisation.
Utilisons ces fonctions pour créer une socket :
Function tuto1()
Dim lData As WSADATA
Dim lsock As Long
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
' Création d'une socket
lsock = socket(AF_INET, SOCK_STREAM, 0)
If lsock <> -1 Then
' le code suivant est à ajouter ici
closesocket lsock
End If
WSACleanup
End If
End Function
La fonction socket renvoie un identifiant qu'il faut conserver pour utiliser la socket.
Si la création de fonctionne pas, la fonction renvoie -1 et il faut lire la valeur de Err.LastDllError pour connaître le code d'erreur.
closesocket ferme la socket une fois celle-ci devenue inutile.
X-D. Connecter une socket▲
Une socket peut être connectée à un serveur pourvu que celui-ci accepte des connexions .
Si vous êtes derrière un proxy, il faut vous connecter au proxy et non directement au serveur ciblé.
Pour une connexion FTP à travers un proxy, voir le chapitre Connexion à un serveur FTP.
Nous allons ici nous connecter à un serveur SMTP (serveur d'envoi de mail).
N'ayant pas de proxy SMTP à ma disposition, je n'ai pas pu tenter l'envoi de mail via un proxy SMTP.
La connexion est donc, dans cet exemple, directe sans proxy.
Utilisons par exemple le serveur SMTP de free.
Ce serveur est smtp.free.fr:25.
La fonction de connexion est Connect qui se déclare ainsi :
Public Declare Function Connect Lib "ws2_32.dll" Alias "connect" (ByVal hSocket As Long, ByRef Name As SOCKADDR, ByVal NameLen As Long) As Long
Private Type SOCKADDR
sin_family As Integer
sin_port(1 To 2) As Byte ' équivalent de u_short
sin_addr As Long 'structure IN_ADDR
sin_zero As String * 7
End Type
Cette fonction accepte trois paramètres :
- hSocket est l'identifiant de la socket créée avec la fonction socket ;
- Name est une structure de type SOCKADDR qui contient les informations de connexion ;
- NameLen est la taille de la structure SOCKADDR (à retrouver avec l'instruction LenB).
La structure SOCKADDR n'est pas si facile à renseigner :
- le premier élément sin_family est égal à AF_INET comme pour l'appel à la fonction socket ;
- le deuxième élément sin_port est le port ciblé (25) ; voir la suite pour le détail ;
- le troisième élément sin_addr est l'adresse du serveur ciblé (smtp.free.fr) ; voir la suite pour le détail ;
- le quatrième élément sin_zero est inutilisé.
Voici déjà le code sans le port et le serveur :
Function tuto1()
Dim lData As WSADATA
Dim lsock As Long
Dim lname As SOCKADDR
Dim lRet As Long
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
' Création d'une socket
lsock = socket(AF_INET, SOCK_STREAM, 0)
If lsock <> -1 Then
lname.sin_family = AF_INET ' famille "classique"
' Ici on ajoutera le paramétrage du port et du serveur
lRet = Connect(lsock, lname, LenB(lname))
If lRet = 0 Then
' le code de dialogue avec la socket sera à ajouter ici
End If
closesocket lsock
End If
WSACleanup
End If
End Function
Le retour de la fonction connect renvoie 0 si la connexion est établie.
X-E. Le port sin_port▲
L'élément sin_port est un entier non signé (u_short en C).
Sa valeur est de 0 à 65535, stockée sur deux bytes.
On utilise habituellement la fonction htons de la librairie Winsock qui permet d'"inverser" ces deux bytes car les fonctions Winsock demandent un ordre de type "big endian".
Public Declare Function htons Lib "ws2_32.dll" (ByVal HostShort As Integer) As Integer
Par exemple la valeur 10000 est égale à 39 * 256 + 16 et est stockée ainsi : 16 39.
Pour Winsock il faut inverser et stocker le nombre ainsi : 39 16.
Donc 16 * 256 + 39 = 4135.
La fonction htons nous renvoie bien 4135.
Un problème survient si on souhaite utiliser le port 50000 par exemple. La fonction htons renvoie une erreur en VBA car 50000 dépasse la capacité d'un Integer.
En VBA nous n'avons pas d'entier non signé : Integer est un entier signé dont la valeur est comprise entre -32 768 et 32 767.
C'est pour cela que j'ai déclaré sin_port en tableau de deux bytes.
Il nous suffit de calculer nous-mêmes les deux bytes :
- la première valeur : 50000 \ 256 = 195
- la deuxième valeur : 50000 mod 256 = 80
On calcule pour information : 80 * 256 + 195 = 20675.
20675 est la valeur que nous aurait renvoyé htons si on avait un entier non signé à notre disposition dans VBA.
Voici donc le paramétrage du port 25 :
[...]
If lsock <> -1 Then
lname.sin_family = AF_INET ' famille "classique"
lname.sin_port(1) = 25 \ 256 ' première partie du port
lname.sin_port(2) = 25 Mod 256 ' deuxième partie du port
[...]Il est cependant tout à fait possible d'utiliser la fonction htons pour des ports compris entre 0 et 32 767 (avec sin_port de type Integer dans le type SOCKADDR).
X-F. Le serveur sin_addr▲
Voici un paramètre bien compliqué.
sin_addr est un entier long, alors que l'adresse de notre hôte est une chaîne de caractères (stmp.free.fr).
Voici les déclarations dont nous avons besoin :
Public Declare Function gethostbyname Lib "ws2_32.dll" (ByVal Name As String) As Long
Public Declare Function inet_addr Lib "ws2_32.dll" (ByVal IpAddress As String) As Long
Public Declare Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, Source As Any, ByVal length As Long)
Public Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLength As Integer
hAddrList As Long
End Type
- gethostbyname permet de trouver l'adresse IP d'un serveur à partir de son nom (à travers la structure HOSTENT).
- inet_addr permet de transformer l'adresse IP en un entier long.
- RtlMoveMemory est une fonction de l'API Windows qui nous permet de déplacer des zones de mémoire.
Dans le module modWinsock, nous créons une fonction qui permet de transformer le nom du serveur en une adresse dans un entier long pour l'élément sin_addr :
cette fonction doit être écrite après toutes les déclarations du module.
' -------------------------------------------------------------
' Donnez un nom de serveur en entrée: par exemple smtp.free.fr
' Retourne un entier long pour utilisation dans sin_addr
' WSAStartup doit être exécuté avant cette fonction
' -------------------------------------------------------------
Public Function addrfromhost(host As String) As Long
Dim lHostEnt As HOSTENT
Dim lHost As Long
Dim lAddress() As Byte
Dim lHostAddress As Long
' lhost est un pointeur vers une structure HOSTENT
lHost = gethostbyname(host)
If lHost <> 0 Then
' Déplace le contenu mémoire à l'emplacement du pointeur lHost vers la structure lHostEnt
RtlMoveMemory lHostEnt, ByVal lHost, LenB(lHostEnt)
' Prépare un tableau contenant les 4 parties de l'adresse
ReDim lAddress(1 To lHostEnt.hLength) As Byte
' Récupère le pointeur de l'adresse dans lHostAddress
' hAddrList est un pointeur vers un pointeur
RtlMoveMemory lHostAddress, ByVal lHostEnt.hAddrList, lHostEnt.hLength
' Déplace l'adresse dans le tableau lAddress
RtlMoveMemory lAddress(1), ByVal lHostAddress, lHostEnt.hLength
' Transforme l'adresse (ex : 212.29.48.4) en entier long avec inet_addr
' et retourne cette valeur
addrfromhost = inet_addr(lAddress(1) & "." & lAddress(2) & "." & lAddress(3) & "." & lAddress(4))
End If
End Function
Il suffit ensuite d'utiliser cette fonction pour remplir l'élément sin_addr :
[...]
If lsock <> -1 Then
lname.sin_family = AF_INET ' famille "classique"
lname.sin_port(1) = 25 \ 256 ' première partie du port
lname.sin_port(2) = 25 Mod 256 ' deuxième partie du port
lname.sin_addr = addrfromhost("smtp.free.fr") ' adresse du serveur
[...]X-G. Récapitulatif▲
Voici le code complet de connexion, à utiliser avec le module modWinsock qui contient les déclarations :
Function tuto1()
Dim lData As WSADATA
Dim lsock As Long
Dim lname As SOCKADDR
Dim lRet As Long
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
' Création d'une socket
lsock = socket(AF_INET, SOCK_STREAM, 0)
If lsock <> -1 Then
lname.sin_family = AF_INET ' famille "classique"
lname.sin_port(1) = 25 \ 256 ' première partie du port
lname.sin_port(2) = 25 Mod 256 ' deuxième partie du port
lname.sin_addr = addrfromhost("smtp.free.fr") ' adresse du serveur
' Connexion
lRet = Connect(lsock, lname, LenB(lname))
If lRet = 0 Then
' le code de dialogue avec la socket sera à ajouter ici
MsgBox "connecté!" ' Boîte de dialogue pour test
End If
closesocket lsock
End If
WSACleanup
End If
End Function
Si le retour de la fonction Connect est 0, la socket est bien connectée au serveur.
Sinon, il faut regarder la valeur de Err.LastDllError pour connaître le code d'erreur.
Par exemple, une tentative de connexion sur le port 26 lève une erreur 10061 : Connexion refusée.
X-H. Recevoir des données▲
Nous avons envoyé une demande de connexion au serveur, il s'agit maintenant de lire sa réponse.
C'est la fonction recv qui se charge de la lecture.
Public Declare Function recv Lib "ws2_32.dll" (ByVal hSocket As Long, ByRef buffer As Any, ByVal BufferLength As Long, ByVal Flags As Long) As Long
Public Declare Function recvstr Lib "ws2_32.dll" Alias "recv" (ByVal hSocket As Long, ByVal buffer As String, ByVal BufferLength As Long, ByVal Flags As Long) As Long
La fonction recv accepte quatre paramètres :
- hSocket est l'identifiant de la socket ;
- buffer contiendra les données reçues, il doit être dimensionné de la taille de BufferLength au minimum ;
- BufferLength est la taille des données à recevoir ;
- Flags est un paramètre que nous n'utiliserons pas.
Nous ne connaissons pas par avance la taille des données à recevoir.
Pour faire simple, nous allons d'abord nous contenter de lire 1024 caractères, ce qui sera suffisant pour cette première lecture.
Notez que nous avons déclaré une fonction srecvstr qui est un appel à la fonction recv mais avec un type de paramètre différent pour le buffer.
Cette fonction sera utile pour recevoir facilement des chaînes de caractères.
La réception de chaînes de caractères (String) avec la fonction recv nécessiterait une conversion des données avec StrConv.
[...]
' Connexion
lRet = Connect(lsock, lname, LenB(lname))
If lRet = 0 Then
' Réception des données de connexion
lStrToReceive = Space(1024)
lRet = recvstr(lsock, lStrToReceive, Len(lStrToReceive), 0)
If lRet > 0 Then
lStrToReceive = Left(lStrToReceive, lRet)
Debug.Print "Octets reçus : " & lRet & vbCrLf & lStrToReceive
End If
[...]
Pour recevoir des données, on remplit d'abord une variable lStrToReceive par des espaces.
La fonction retourne la taille des données lues, ce qui permet de tronquer la variable à la bonne taille.
Voici le résultat obtenu :
Octets reçus : 37
220 smtp1-g21.free.fr ESMTP Postfix
À noter :
- la fonction de réception est synchrone : c'est-à-dire que l'exécution est interrompue tant que des données ne sont pas reçues ;
- il est utile de vérifier au préalable si le serveur a envoyé des données, sinon on risque de bloquer l'exécution ;
- il est également utile de vérifier que toutes les données ont été lues.
Nous tiendrons compte de ces dernières remarques dans le chapitre suivant sur l'envoi/réception avec timeout.
X-I. Envoyer des données▲
Une fois connecté, on souhaite envoyer (et recevoir) des données.
Comme nous sommes connectés à un serveur SMTP, nous allons envoyer une commande EHLO qui est la première commande à exécuter pour ce type de serveur.
L'envoi de données se fait à l'aide de la fonction send.
Public Declare Function send Lib "ws2_32.dll" (ByVal hSocket As Long, ByRef buffer As Any, _
ByVal BufferLength As Long, ByVal Flags As Long) As Long
Public Declare Function sendstr Lib "ws2_32.dll" Alias "send" (ByVal hSocket As Long, _
ByVal buffer As String, ByVal BufferLength As Long, ByVal Flags As Long) As Long
La fonction send accepte quatre paramètres :
- hSocket est l'identifiant de la socket ;
- buffer contient les données à envoyer ;
- BufferLength est la taille des données à envoyer ;
- Flags est un paramètre que nous n'utiliserons pas.
Elle retourne le nombre de caractères effectivement envoyés.
En cas d'erreur d'envoi, la fonction retourne -1.
Il est possible que les données ne soient pas entièrement envoyées en une fois.
Il faut alors envoyer le reste des données jusqu'à ce que tout soit envoyé.
Notez que nous avons déclaré une fonction sendstr qui est un appel à la fonction send mais avec un type de paramètre différent pour le buffer.
Cette fonction sera utile pour envoyer facilement des chaînes de caractères.
L'envoi de chaînes de caractères (String) avec la fonction send nécessiterait une conversion des données avec StrConv.
Une fois la commande envoyée, nous lisons ensuite la réponse du serveur.
[...]
' Connexion
lRet = Connect(lsock, lname, LenB(lname))
If lRet = 0 Then
' Envoi d'une commande EHLO
lStrToSend = "EHLO smtp.free.fr" & vbCrLf
' Envoi des données
lRet = sendstr(lsock, lStrToSend, Len(lStrToSend), 0)
Debug.Print "Octets envoyés : " & lRet & " / " & Len(lStrToSend)
' Réception des données
lStrToReceive = Space(1024)
lRet = recvstr(lsock, lStrToReceive, Len(lStrToReceive), 0)
If lRet > 0 Then
lStrToReceive = Left(lStrToReceive, lRet)
Debug.Print "Octets reçus : " & lRet & vbCrLf & lStrToReceive
End If
Else
Debug.Print "Erreur de connexion n° " & Err.LastDllError
End If
[...]Le VbCrLf en fin de commande est un saut de ligne indispensable pour demander l'exécution de la commande.
Si tout se passe bien, lRet doit contenir 19 qui est la taille des données envoyées.
À noter :
- la fonction d'envoi est synchrone : c'est-à-dire que l'exécution est interrompue tant que les données ne sont pas envoyées ;
- il est utile de vérifier avant envoi si le serveur est prêt à recevoir des données, sinon on risque de bloquer l'exécution ;
- il est également utile de vérifier que toutes les données ont été envoyées.
Nous tiendrons compte de ces dernières remarques dans le chapitre suivant sur l'envoi/réception avec timeout.
Voici le code complet d'envoi/réception de données, à utiliser avec le module modWinsock qui contient les déclarations :
Function tuto1()
Dim lData As WSADATA
Dim lsock As Long
Dim lname As SOCKADDR
Dim lRet As Long
Dim lStrToSend As String
Dim lStrToReceive As String
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
' Création d'une socket
lsock = socket(AF_INET, SOCK_STREAM, 0)
If lsock <> -1 Then
lname.sin_family = AF_INET ' famille "classique"
lname.sin_port(1) = 25 \ 256 ' première partie du port
lname.sin_port(2) = 25 Mod 256 ' deuxième partie du port
lname.sin_addr = addrfromhost("smtp.free.fr") ' adresse du serveur
' Connexion
lRet = Connect(lsock, lname, LenB(lname))
If lRet = 0 Then
' Réception des données de connexion
lStrToReceive = Space(1024)
lRet = recvstr(lsock, lStrToReceive, Len(lStrToReceive), 0)
If lRet > 0 Then
lStrToReceive = Left(lStrToReceive, lRet)
Debug.Print "Octets reçus : " & lRet & vbCrLf & lStrToReceive
End If
' Envoi d'une commande EHLO
lStrToSend = "EHLO smtp.free.fr" & vbCrLf
' Envoi des données
lRet = sendstr(lsock, lStrToSend, Len(lStrToSend), 0)
Debug.Print "Octets envoyés : " & lRet & " / " & Len(lStrToSend)
' Réception des données
lStrToReceive = Space(1024)
lRet = recvstr(lsock, lStrToReceive, Len(lStrToReceive), 0)
If lRet > 0 Then
lStrToReceive = Left(lStrToReceive, lRet)
Debug.Print "Octets reçus : " & lRet & vbCrLf & lStrToReceive
End If
Else
MsgBox "Erreur de connexion n° " & Err.LastDllError
End If
closesocket lsock
End If
WSACleanup
End If
End Function
Si vous exécutez ce code derrière un proxy, vous obtiendrez certainement une erreur (dans mon cas : erreur 10054 sur réception de données).
Sinon, voici le résultat obtenu :
Octets reçus : 37
220 smtp1-g21.free.fr ESMTP Postfix
Octets envoyés : 19 / 19
Octets reçus : 126
250-smtp1-g21.free.fr
250-PIPELINING
250-SIZE 35000000
250-VRFY
250-ETRN
250-ENHANCEDSTATUSCODES
250-8BITMIME
250 DSN
Ceci est le texte renvoyé par le serveur.
X-J. Envoyer et recevoir des données avec Timeout▲
Dans les deux chapitres précédents nous avons envoyé et reçu des données de manière simple.
Pour couvrir tous les cas possibles, il est utile de créer des fonctions d'envoi et de réception qui font quelques vérifications et s'assurent que les données ont bien été envoyées ou reçues en totalité.
De plus, programmer un timeout est presque indispensable pour ne pas se retrouver bloqué en attente d'envoi ou de réception.
La fonction qui nous permet de vérifier si la socket est prête à envoyer ou recevoir est la fonction select :
Public Declare Function wselect Lib "ws2_32.dll" Alias "select" (ByVal Reserved As Long, _
ByRef ReadFds As FD_SET, ByRef WriteFds As FD_SET, _
ByRef ExceptFds As FD_SET, ByRef timeout As TIMEVAL) As Long
Public Type FD_SET
fd_count As Long
fd_array(1 To 64) As Long
End Type
Public Type TIMEVAL
tv_sec As Long
tv_usec As Long
End Type
select étant un mot-clé réservé de VBA, j'ai appelé la fonction wselect.
Les types FD_SET et TIMEVAL sont utilisés par cette fonction.
On a cinq paramètres en entrée :
- Reserved est inutilisé ;
- ReadFds est une structure de type FD_SET définissant les sockets à vérifier pour lecture (=réception) ;
- WriteFds est une structure de type FD_SET définissant les sockets à vérifier pour écriture (=envoi) ;
- ExceptFds est une structure de type FD_SET définissant les sockets à vérifier pour statut en erreur ;
- timeout est une structure de type TIMEVAL définissant le timeout.
Chaque structure FD_SET doit être remplie ainsi :
- fd_count est le nombre de sockets à vérifier ;
- fd_array est un tableau d'identifiant de socket.
La structure TIMEVAL doit être remplie ainsi :
- tv_sec est un temps en secondes ;
- tv_usec est un temps en microsecondes ;
Ces deux temps sont cumulés.
La fonction renvoie le nombre de sockets prêtes.
Si le temps défini est écoulé, la fonction renvoie 0.
S'il y a une erreur, la fonction renvoie -1.
Voici deux fonctions pour envoyer et recevoir des données de type String avec un délai en secondes (10 par défaut) :
' -----------------------------------------------------------------------------
' Réception de données (String) sur une socket sock avec timeout en secondes
' Si retour = -1 => erreur
' -----------------------------------------------------------------------------
Public Function RecvStrTO(sock, Optional timeout As Long = 10) As String
Dim lBuffer As String
Dim lfdr As FD_SET, lfdw As FD_SET, lfde As FD_SET
Dim lret As Long
Dim lti As TIMEVAL
' délai en secondes
lti.tv_sec = timeout
' une socket à vérifier
lfdr.fd_count = 1
' la socket passée en paramètre
lfdr.fd_array(1) = sock
' la socket est-elle prête?
lret = wselect(0, lfdr, lfdw, lfde, lti)
' Si pas d'erreur et délai non dépassé
If lret > 0 Then
' Boucle tant qu'il y a des données
Do
' Si socket prête
If lfdr.fd_count = 1 Then
' Réception
lBuffer = Space(1024)
lret = recvstr(sock, lBuffer, 1024, 0)
' Ajoute les données reçues au résultat
If lret > 0 Then
lBuffer = Left(lBuffer, lret)
RecvStrTO = RecvStrTO & lBuffer
ElseIf lret = 0 Then
Exit Do
ElseIf lret < 0 Then
RecvStrTO = "-1"
Exit Do
End If
End If
' Vérifie s'il y a encore des données à recevoir (avec délai à 1 usec)
lfdr.fd_count = 1
lti.tv_sec = 0
lti.tv_usec = 1
lret = wselect(0, lfdr, lfdw, lfde, lti)
If lret <= 0 Then
Exit Do
End If
Loop
End If
End Function
' -----------------------------------------------------------------------------
' Envoi de données (String) sur une socket sock avec timeout en secondes
' Cette fonction renvoit True si l'envoi est correct
' -----------------------------------------------------------------------------
Public Function SendStrTO(sock, ByVal StrToSend As String, Optional timeout As Long = 10) As Boolean
Dim lBuffer As String
Dim lfdr As FD_SET, lfdw As FD_SET, lfde As FD_SET
Dim lret As Long
Dim lti As TIMEVAL
' délai en secondes
lti.tv_sec = timeout
' une socket à vérifier
lfdw.fd_count = 1
' la socket passée en paramètre
lfdw.fd_array(1) = sock
' la socket est-elle prête?
lret = wselect(0, lfdr, lfdw, lfde, lti)
' Si pas d'erreur et délai non dépassé
If lret > 0 Then
' Boucle tant qu'il y a des données à envoyer
Do
' Si socket prête
If lfdw.fd_count = 1 Then
' Envoi
lret = sendstr(sock, StrToSend, Len(StrToSend), 0)
' Test le retour
If lret = -1 Then
' Erreur
SendStrTO = False
Exit Do
Else
If lret < Len(StrToSend) Then
' Envoi partiel
StrToSend = Mid(StrToSend, lret + 1)
Else
' Envoi terminé
SendStrTO = True
Exit Do
End If
End If
End If
Loop
End If
End Function
Et la fonction du tutoriel modifiée pour utiliser ces deux nouvelles fonctions :
Function tuto1()
Dim lData As WSADATA
Dim lsock As Long
Dim lname As SOCKADDR
Dim lRet As Long
Dim lStrToSend As String
Dim lStrToReceive As String
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
' Création d'une socket
lsock = socket(AF_INET, SOCK_STREAM, 0)
If lsock <> -1 Then
lname.sin_family = AF_INET ' famille "classique"
lname.sin_port(1) = 25 \ 256 ' première partie du port
lname.sin_port(2) = 25 Mod 256 ' deuxième partie du port
lname.sin_addr = addrfromhost("smtp.free.fr") ' adresse du serveur
' Connexion
lRet = Connect(lsock, lname, LenB(lname))
If lRet = 0 Then
' Envoi d'une commande EHLO
lStrToSend = "EHLO smtp.free.fr" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
Else
Debug.Print "Erreur de connexion n° " & Err.LastDllError
End If
closesocket lsock
End If
WSACleanup
End If
End Function
Ces deux fonctions vont nous être utiles pour la suite.
X-K. Envoyer des mails par SMTP▲
L'envoi de mail se fait à l'aide d'envoi de commandes successives.
Pour savoir quelles commandes il faut envoyer, vous pouvez chercher sur internet par exemple avec les mots-clés SMTP Telnet.
X-K-1. Mail Free (sans authentification)▲
Voici un exemple d'envoi de mail :
Function tuto_mail_free()
Dim lData As WSADATA
Dim lsock As Long
Dim lname As SOCKADDR
Dim lRet As Long
Dim lStrToSend As String
Dim lStrToReceive As String
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
' Création d'une socket
lsock = socket(AF_INET, SOCK_STREAM, 0)
If lsock <> -1 Then
lname.sin_family = AF_INET ' famille "classique"
lname.sin_port(1) = 25 \ 256 ' première partie du port
lname.sin_port(2) = 25 Mod 256 ' deuxième partie du port
lname.sin_addr = addrfromhost("smtp.free.fr") ' adresse du serveur
' Connexion
lRet = Connect(lsock, lname, LenB(lname))
If lRet = 0 Then
' Réception des données de connexion
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
' Envoi d'une commande EHLO
lStrToSend = "EHLO smtp.free.fr" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Envoi du mail source
lStrToSend = "MAIL FROM: <monmail.source@free.fr>" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Envoi du mail cible
lStrToSend = "RCPT TO: <monmail.cible@hotmail.fr>" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Début des données
lStrToSend = "DATA" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Objet du mail
lStrToSend = "SUBJECT: Test Tuto DVP Winsock" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Contenu du mail
lStrToSend = "Contenu du mail." & vbCrLf & "Utilisez vbCrLf pour passer à la ligne" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Fin du contenu => déclenche l'envoi du mail
lStrToSend = "." & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Quitte le serveur
lStrToSend = "quit" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
Else
Debug.Print "Erreur de connexion n° " & Err.LastDllError
End If
closesocket lsock
End If
WSACleanup
End If
End Function
Remarque : pour marquer la fin du contenu du mail et déclencher l'envoi, il faut envoyer un point suivi d'un retour à la ligne.
Voici le résultat obtenu dans la fenêtre Exécution :
Octets reçus : 37 220 smtp1-g21.free.fr ESMTP Postfix Commande envoyée : EHLO smtp.free.fr Octets reçus : 126 250-smtp1-g21.free.fr 250-PIPELINING 250-SIZE 35000000 250-VRFY 250-ETRN 250-ENHANCEDSTATUSCODES 250-8BITMIME 250 DSN Commande envoyée : MAIL FROM: <monmail.source@free.fr> Octets reçus : 14 250 2.1.0 Ok Commande envoyée : RCPT TO: <monmail.cible@hotmail.fr> Octets reçus : 14 250 2.1.5 Ok Commande envoyée : DATA Octets reçus : 37 354 End data with <CR><LF>.<CR><LF> Commande envoyée : SUBJECT: Test Tuto DVP Winsock Octets reçus : 0 Commande envoyée : Contenu du mail. Utilisez vbCrLf pour passer à la ligne Octets reçus : 0 Commande envoyée : . Octets reçus : 37 250 2.0.0 Ok: queued as 5F97D940072 Commande envoyée : quit Octets reçus : 15 221 2.0.0 Bye
On peut bien sûr exploiter les données reçues pour lire les codes retour et réagir en cas d'erreur.
Notez que certaines commandes (celles qui envoient les données du mail, après la commande DATA) ne donnent pas lieu à une réponse du serveur.
On peut retirer les lectures d'information inutiles qui ralentissent le traitement en attente du timeout.
Notez également que sur le mail reçu, l'accent n'est pas correctement restitué.
Il est possible d'envoyer, avant le contenu du mail, le codage à utiliser :
' En-tête des données
lStrToSend = "Content-Type: text/plain; charset=""iso-8859-1""" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
End If
On définit ici un contenu texte brut (text/plain) avec un codage (charset) iso-8859-1.
Les accents sont alors correctement restitués.
Les valeurs possibles de la valeur de Content-Type sont listées ici : MIME Media Types.
Il est par exemple possible d'envoyer un contenu de mail en HTML en précisant un type text/HTML :
[...]
' En-tête des données
lStrToSend = "Content-Type: text/HTML; charset=""iso-8859-1""" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
End If
' Contenu du mail
lStrToSend = "<b>Contenu du mail.</b>" & "<br/>" & "<i>Utilisez <br/> pour passer à la ligne</i>" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
End If
[...]Le serveur SMTP de free ne demande pas d'authentification.
On peut donc l'utiliser sans même avoir de compte chez free.
X-K-2. Mail Hotmail (avec authentification)▲
Le serveur hotmail est smtp.live.com sur le port 587.
Ce serveur demande une authentification : il faut donc un Windows Live ID (compte Hotmail ou Messenger) pour l'utiliser.
Les informations de connexion doivent être codées en Base64.
Nous allons créer une fonction de codage en Base64 grâce à la librairie crypt32.dll apparue avec Windows XP.
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' -----------------------------------------------------------------------------
' Codage Base64
' -----------------------------------------------------------------------------
Public Function Base64(ByVal pStr As String) As String
Dim lStrReturn As String
Dim lStrLen As Long
' Récupère la taille nécessaire
Call CryptBinaryToString(pStr, Len(pStr), CRYPT_STRING_BASE64, vbNullString, lStrLen)
If (lStrLen > 0) Then
lStrReturn = Space$(lStrLen - 1) ' on retire le chr(0) final
' Code en Base64
Call CryptBinaryToString(pStr, Len(pStr), CRYPT_STRING_BASE64, lStrReturn, lStrLen - 1)
End If
Base64 = lStrReturn
End FunctionBase64 est un codage et non un cryptage.
Ce n'est nullement une sécurisation des informations.
Le codage en Base64 avec la fonction CryptBinaryToString ajoute automatiquement un saut de ligne (vbCrLf) en fin de chaîne.
Il ne faut donc pas en ajouter un second lors de l'envoi de la commande.
Voici un exemple d'envoi de mail avec Hotmail :
Function tuto_mail_hotmail()
Dim lData As WSADATA
Dim lsock As Long
Dim lname As SOCKADDR
Dim lRet As Long
Dim lStrToSend As String
Dim lStrToReceive As String
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
' Création d'une socket
lsock = socket(AF_INET, SOCK_STREAM, 0)
If lsock <> -1 Then
lname.sin_family = AF_INET ' famille "classique"
lname.sin_port(1) = 587 \ 256 ' première partie du port
lname.sin_port(2) = 587 Mod 256 ' deuxième partie du port
lname.sin_addr = addrfromhost("smtp.live.com") ' adresse du serveur
' Connexion
lRet = Connect(lsock, lname, LenB(lname))
If lRet = 0 Then
' Réception des données de Connexion
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
' Envoi d'une commande EHLO
lStrToSend = "EHLO smtp.live.com" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Envoi d'une commande d'authentification
lStrToSend = "AUTH LOGIN" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Envoi de l'ID = login
lStrToSend = Base64("monmail@hotmail.fr")
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Envoi du mot de passe
lStrToSend = Base64("MonMotDePasse")
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Envoi du mail source
lStrToSend = "MAIL FROM: <monmail.source@hotmail.fr>" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsoc)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Envoi du mail cible
lStrToSend = "RCPT TO: <monmail.cible@free.fr>" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Début des données
lStrToSend = "DATA" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Objet du mail
lStrToSend = "SUBJECT: Test Tuto DVP Winsock" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
End If
' Contenu du mail
lStrToSend = "Contenu du mail." & vbCrLf & "Utilisez vbCrLf pour la ligne suivante" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
End If
' Fin du contenu => déclenche l'envoi du mail
lStrToSend = "." & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Quitte le serveur
lStrToSend = "quit" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
Else
Debug.Print "Erreur de connexion n° " & Err.LastDllError
End If
closesocket lsock
End If
WSACleanup
End If
End FunctionX-K-3. Envoi de pièces jointes▲
L'envoi de pièce jointe se fait avec un format très précis.
Le contenu du mail doit être écrit dans un élément multipart/mixed.
La construction des données ressemble fortement à ce qu'on a vu dans le chapitre Passage de paramètres multiples complexes.
Une pièce jointe s'envoie généralement en codage base64 (comme pour l'authentification SMTP avec AUTH LOGIN).
Voici un exemple d'envoi de fichier texte joint :
Function tuto_mail_hotmail_avec_piece_jointe()
Dim lData As WSADATA
Dim lsock As Long
Dim lname As SOCKADDR
Dim lret As Long
Dim lStrToSend As String
Dim lStrToReceive As String
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
' Création d'une socket
lsock = socket(AF_INET, SOCK_STREAM, 0)
If lsock <> -1 Then
lname.sin_family = AF_INET ' famille "classique"
lname.sin_port(1) = 587 \ 256 ' première partie du port
lname.sin_port(2) = 587 Mod 256 ' deuxième partie du port
lname.sin_addr = addrfromhost("smtp.live.com") ' adresse du serveur
' Connexion
lret = Connect(lsock, lname, LenB(lname))
If lret = 0 Then
' Réception des données de connexion
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
' Envoi d'une commande EHLO
lStrToSend = "EHLO smtp.live.com" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Envoi d'une commande d'authentification
lStrToSend = "AUTH LOGIN" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Envoi de l'ID = login
lStrToSend = Base64("monID@hotmail.fr")
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Envoi du mot de passe
lStrToSend = Base64("monMotDePasse")
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Envoi du mail source
lStrToSend = "MAIL FROM: <monmail.source@hotmail.fr>" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Envoi du mail cible
lStrToSend = "RCPT TO: <monmail.cible@free.fr>" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Début des données
lStrToSend = "DATA" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Objet du mail
lStrToSend = "SUBJECT: Test Tuto DVP Winsock" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
End If
' Contenu du mail
lStrToSend = "MIME-Version: 1.0" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
End If
lStrToSend = "Content-type: multipart/mixed;boundary=""ax0rt1232"")" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
End If
lStrToSend = vbCrLf & "--ax0rt1232" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
End If
lStrToSend = "Content-type: text/plain" & vbCrLf & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
End If
lStrToSend = "Contenu du mail." & vbCrLf & "Utilisez vbCrLf pour passer a la ligne" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
End If
lStrToSend = "--ax0rt1232" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
End If
lStrToSend = "Content-Type: application/text; name=""myfile.txt""" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
End If
lStrToSend = "Content-Transfer-Encoding: base64" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
End If
lStrToSend = "Content-Disposition: attachment; filename=""myfile.txt""" & vbCrLf & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
End If
lStrToSend = Base64("Contenu du fichier")
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
End If
lStrToSend = "--ax0rt1232--" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
End If
' Fin du contenu => déclenche l'envoi du mail
lStrToSend = "." & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Quitte le serveur
lStrToSend = "quit" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
Else
Debug.Print "Erreur de connexion n° " & Err.LastDllError
End If
closesocket lsock
End If
WSACleanup
End If
End FunctionX-L. Gestion d'un serveur FTP▲
Un autre serveur bien connu est le serveur FTP.
Les sockets vont nous permettre de réaliser (au prix de quelques efforts) toutes les opérations habituelles d'un client FTP.
On pourra même se connecter à travers un proxy.
Afin de tester le serveur et visualiser les commandes utiles, je vous conseille d'installer FileZilla, un client FTP gratuit.
La connexion à un serveur FTP se fait différemment en fonction du type de proxy éventuellement utilisé.
Un lien (en anglais) sur le sujet : How Proxy Server serves FTP clients?
On peut également se connecter avec FileZilla et voir les commandes envoyées.
Ce qu'il faut bien retenir :
- si la connexion est directe : on connecte la socket au serveur FTP directement.
- si la connexion passe par un proxy : on connecte la socket au proxy qui se chargera de communiquer avec le serveur FTP.
Nous utiliserons le module modWinsock du chapitre précédent.
Mais attention : le serveur FTP peut envoyer des données en plusieurs fois.
La norme FTP défini que l'envoi est terminé lorsqu'on reçoit une ligne avec un code (3 chiffres) suivi d'un espace.
Afin d'éviter un décalage entre les envois et réceptions de message, nous allons ajouter une nouvelle fonction qui va lire en boucle les messages du serveur jusqu'à recevoir le code de fin d'envoi (3 chiffres + un espace).
Voici cette fonction RecvStrTOFTP :
' -----------------------------------------------------------------------------
' Réception de données (String) depuis FTP (attente d'un code suivi d'un espace)
' Cf. RFC 959, section 4.2
' -----------------------------------------------------------------------------
Public Function RecvStrTOFTP(sock, Optional timeout As Long = 15) As String
Dim lBuffer As String
Dim lPos As Long
Dim lcpt As Long
Do
lcpt = lcpt + 1
lBuffer = RecvStrTO(sock, IIf(lcpt = 1, timeout, 1))
If lBuffer = "" Then Exit Do
If lBuffer = "-1" Then
lBuffer = "999 Erreur de socket" & vbCrLf
End If
RecvStrTOFTP = RecvStrTOFTP & lBuffer
If lBuffer Like "### *" Or lBuffer Like "*" & vbCrLf & "#### *" Then
Exit Do
End If
Loop
End FunctionX-L-1. Connexion à un serveur sans proxy▲
Dans ce cas on se connecte directement au serveur FTP, puis on envoie les commandes d'authentification.
La connexion est identique à ce que nous avons réalisé précédemment pour l'envoi de mail par un serveur SMTP.
Function ConnectFTPSansProxy()
Dim lData As WSADATA
Dim lsock As Long
Dim lname As SOCKADDR
Dim lStrToSend As String
Dim lStrToReceive As String
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
' Création d'une socket
lsock = socket(AF_INET, SOCK_STREAM, 0)
If lsock <> -1 Then
lname.sin_family = AF_INET ' famille "classique"
' Le port est généralement 21 pour du FTP
lname.sin_port(1) = 21 \ 256 ' première partie du port
lname.sin_port(2) = 21 Mod 256 ' deuxième partie du port
lname.sin_addr = addrfromhost("MonSiteFTP.com") ' adresse du serveur
' Connexion
If Connect(lsock, lname, LenB(lname)) = 0 Then
' Réception des données de connexion
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
' Envoi du nom d'utilisateur
lStrToSend = "USER monUtilisateur" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTOFTP(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Envoi du mot de passe
lStrToSend = "PASS monMotDePasse" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTOFTP(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Quitte le serveur
lStrToSend = "quit" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTOFTP(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
Else
Debug.Print "Erreur de connexion n° " & Err.LastDllError
End If
closesocket lsock
End If
WSACleanup
End If
End Function
Et voici le résultat obtenu dans la fenêtre Exécution :
Octets reçus : 63
220 XX-XX-XX-XX.ovh.net NcFTPd Server (licensed copy) ready.
Commande envoyée :
USER monUtilisateur
Octets reçus : 40
331 User monUtilisateur okay, need password.
Commande envoyée :
PASS monMotDePasse
Octets reçus : 55
230-You are user #1 of 50 simultaneous users allowed.
Octets reçus : 38
230-
230 Restricted user logged in.
Commande envoyée :
quit
Octets reçus : 14
221 Goodbye.
À noter : je fais deux lectures de données après l'envoi du mot de passe car je ne récupère pas tout la première fois.
Sans doute qu'il y a deux envois de la part du serveur.
X-L-2. Connexion à un serveur avec proxy▲
Si vous êtes derrière un proxy, les commandes à envoyer dépendent du type de proxy.
Dans FileZilla, vous pouvez trouver les différents type de proxy dans le menu : Edition => Paramètres => Paramètres de proxy FTP.
Dans mon cas, je dois choisir USER RemoteID@RemoteHost.
La commande est donc USER monUtilisateur@MonSiteFTP.com.
La fonction de connexion est similaire à la précédente sans proxy sauf que :
- la socket est connectée au proxy (remplacez monproxyftp par l'adresse de votre proxy) ;
- la commande USER contient le nom d'utilisateur et l'adresse du serveur FTP.
Function ConnectFTPAvecProxy()
Dim lData As WSADATA
Dim lsock As Long
Dim lname As SOCKADDR
Dim lStrToSend As String
Dim lStrToReceive As String
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
' Création d'une socket
lsock = socket(AF_INET, SOCK_STREAM, 0)
If lsock <> -1 Then
lname.sin_family = AF_INET ' famille "classique"
' Le port est généralement 21 pour du FTP
lname.sin_port(1) = 21 \ 256 ' première partie du port
lname.sin_port(2) = 21 Mod 256 ' deuxième partie du port
lname.sin_addr = addrfromhost("monproxyftp") ' adresse du serveur
' Connexion
If Connect(lsock, lname, LenB(lname)) = 0 Then
' Réception des données de connexion
lStrToReceive = RecvStrTOFTP(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
' Envoi du nom d'utilisateur
lStrToSend = "USER monUtilisateur@MonSiteFTP.com" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTOFTP(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Envoi du mot de passe
lStrToSend = "PASS monMotDePasse" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTOFTP(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Quitte le serveur
lStrToSend = "quit" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTOFTP(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
Else
Debug.Print "Erreur de connexion n° " & Err.LastDllError
End If
closesocket lsock
End If
WSACleanup
End If
End Function
Et voici le résultat obtenu dans la fenêtre Exécution :
Octets reçus : 27
220 Blue Coat FTP Service
Commande envoyée :
USER monUtilisateur@MonSiteFTP.comm
Octets reçus : 40
331 User monUtilisateur okay, need password.
Commande envoyée :
PASS monMotDePasse
Octets reçus : 93
230-You are user #2 of 50 simultaneous users allowed.
230-
230 Restricted user logged in.
Commande envoyée :
quit
Octets reçus : 41
221 Service closing control connection.
X-L-3. Liste des commandes FTP▲
Les commandes FTP sont normalisées et consultables ici : FILE TRANSFER PROTOCOL (FTP).
Une liste simplifiée est sur Wikipedia : List of FTP commands.
Vous pouvez également faire une opération avec FileZilla et regarder dans le journal des messages quelle est la commande envoyée.
X-L-4. Récupérer la liste des dossiers et fichiers (LIST)▲
Reprenons le code précédent (avec ou sans proxy en fonction de votre cas).
La suite du code s'écrit avant l'envoi de la commande "quit".
Si on regarde avec FileZilla, on s'aperçoit que celui-ci envoie les commandes suivantes :
- TYPE A : passage en mode ASCII (pour du texte car la liste est envoyée en texte ;
- PASV : passage en mode passif (le serveur envoie l'adresse où se connecter pour recevoir les données ;
- LIST : commande qui demande la liste des dossiers et fichiers.
Le mode passif est celui qui a le plus de chances d'aboutir.
C'est le serveur qui donne les informations de connexion au client.
Le mode actif serait défini par la commande PORT.
Pour plus d'information sur la différence entre les modes passif et actif, je vous invite à chercher sur internet où vous trouverez de meilleures explications que les miennes.
Ajoutons alors l'envoi de ces trois commandes :
[...]
' Type ASCII
lStrToSend = "TYPE A" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTOFTP(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Mode passif
lStrToSend = "PASV" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTOFTP(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Demande de la liste
lStrToSend = "LIST" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTOFTP(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
[...]
Et voici le résultat obtenu pour ces trois commandes dans la fenêtre Exécution :
Commande envoyée :
TYPE A
Octets reçus : 16
200 Type okay.
Commande envoyée :
PASV
Octets reçus : 49
227 Entering Passive Mode (87,98,130,52,129,55)
Commande envoyée :
LIST
Octets reçus : 0
Pas de liste de fichiers en vue...
On obtient en fait, en retour de la commande PASV, l'adresse où se connecter pour récupérer la liste.
Les 4 premiers chiffres composent l'adresse IP, les 2 suivants le Port.
On se connecte à cette adresse avec une socket.
La connexion peut se faire juste après la commande PASV.
La lecture des données se fait après l'envoi de la commande LIST.
Le serveur attend notre connexion à la socket de données, c'est pour cela que la commande LIST n'a pas retourné d'information.
Pour récupérer les informations d'adresse, on peut utiliser l'instruction VBA Split.
Voici le code complet de connexion (à adapter si utilisation d'un proxy) et de récupération de la liste des dossiers et fichiers.
Function ConnectFTPSansProxy()
Dim lData As WSADATA
Dim lsock As Long
Dim lname As SOCKADDR
Dim lStrToSend As String
Dim lStrToReceive As String
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
' Création d'une socket
lsock = socket(AF_INET, SOCK_STREAM, 0)
If lsock <> -1 Then
lname.sin_family = AF_INET ' famille "classique"
' Le port est généralement 21 pour du FTP
lname.sin_port(1) = 21 \ 256 ' première partie du port
lname.sin_port(2) = 21 Mod 256 ' deuxième partie du port
lname.sin_addr = addrfromhost("monserveurftp") ' adresse du serveur
' Connexion
If Connect(lsock, lname, LenB(lname)) = 0 Then
' Réception des données de connexion
lStrToReceive = RecvStrTOFTP(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
' Envoi du nom d'utilisateur
lStrToSend = "USER monUtilisateur" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTOFTP(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Envoi du mot de passe
lStrToSend = "PASS monMotDePasse" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTOFTP(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Type ASCII
lStrToSend = "TYPE A" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTOFTP(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Mode passif
lStrToSend = "PASV" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTOFTP(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Création et connexion d'une socket de données
Dim lsockdata As Long ' socket de données
Dim lnamedata As SOCKADDR ' adresse de la socket de données
lsockdata = socket(AF_INET, SOCK_STREAM, 0)
If lsockdata <> -1 Then
Dim lSplit As Variant ' tableau contenant les données entre parenthèses
Dim lPos1 As Long, lPos2 As Long ' position des parenthèses
lPos1 = InStr(lStrToReceive, "(") ' parenthèse ouvrante
lPos2 = InStr(lPos1, lStrToReceive, ")") ' parenthèse fermante
' récupère les informations d'adresse dans un tableau (indice base 0 par défaut)
lSplit = Split(Mid(lStrToReceive, lPos1 + 1, lPos2 - lPos1 - 1), ",")
lnamedata.sin_family = AF_INET ' famille "classique"
' Le port est généralement 21 pour du FTP
lnamedata.sin_port(1) = lSplit(4) ' première partie du port
lnamedata.sin_port(2) = lSplit(5) ' deuxième partie du port
' adresse du serveur
lnamedata.sin_addr = inet_addr(lSplit(0) & "." & lSplit(1) & "." & _
lSplit(2) & "." & lSplit(3))
' Connexion
If Connect(lsockdata, lnamedata, LenB(lnamedata)) = 0 Then
Debug.Print "connexion réussie à la socket de données" & vbCrLf
End If
End If
' Demande de la liste
lStrToSend = "LIST" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTOFTP(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Récupère la liste sur la socket de données
' RecvStrTOFTP n'est pas utile ici, ce n'est pas un message du serveur mais des données
lStrToReceive = RecvStrTO (lsockdata)
Debug.Print "Liste : " & vbCrLf & lStrToReceive
' Ferme la socket de données
closesocket lsockdata
' Quitte le serveur
lStrToSend = "quit" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTOFTP(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
Else
Debug.Print "Erreur de connexion n° " & Err.LastDllError
End If
closesocket lsock
End If
WSACleanup
End If
End Function
Et voici le résultat obtenu dans la fenêtre Exécution :
Octets reçus : 63
220 XX-XX-XX-XX.ovh.net NcFTPd Server (licensed copy) ready.
Commande envoyée :
USER monUtilisateur
Octets reçus : 40
331 User monUtilisateur okay, need password.
Commande envoyée :
PASS monMotDePasse
Octets reçus : 55
230-You are user #1 of 50 simultaneous users allowed.
230-
230 Restricted user logged in.
Commande envoyée :
TYPE A
Octets reçus : 16
200 Type okay.
Commande envoyée :
PASV
Octets reçus : 49
227 Entering Passive Mode (87,98,130,52,223,94)
connexion réussie à la socket de données
Commande envoyée :
LIST
Octets reçus : 76
150 Data connection accepted from 82.229.112.153:49767; transfer starting.
Liste :
drwxr-xr-x 8 developp developp 4096 Jan 27 2010 articles
drwxr-xr-x 5 developp developp 4096 Feb 9 14:26 fichiers
drwxr-xr-x 10 developp developp 4096 Jul 5 15:09 images
-rw-r--r-- 1 developp developp 15115 May 6 2010 index.php
Octets reçus : 24
226 Listing completed.
Commande envoyée :
quit
Octets reçus : 14
221 Goodbye.
La liste obtenue est une liste brute qu'il faut "découper" pour retrouver chaque information.
X-L-5. Télécharger un fichier (RETR)▲
Le téléchargement d'un fichier se fait suivant le même principe que pour la récupération de la liste d'un dossier.
Par contre il faut faire attention au type de transfert (ASCII ou Binaire).
Pour conserver le contenu original du fichier, il faut utiliser un mode Binaire (commande TYPE I).
Le mode ASCII ne convient que pour les fichiers textes qu'il adapte en fonction du système d'exploitation.
Comme nous avons créé une fonction RecvStrTO dédiée à la réception de texte, nous ne pouvons pas l'utiliser pour un contenu binaire de fichier.
De plus, un fichier peut être très volumineux ; il n'est pas concevable de récupérer tout le fichier en mémoire avant de l'écrire sur le disque.
Voici une fonction à ajouter au module modWinsock :
' -----------------------------------------------------------------------------
' Réception de données binaire sur une socket sock avec timeout en secondes
' -----------------------------------------------------------------------------
Public Function RecvBinTO(sock, Optional nbRead As Long = 1024, Optional timeout As Long = 10) As Variant
Dim lBuffer() As Byte
Dim lfdr As FD_SET, lfdw As FD_SET, lfde As FD_SET
Dim lret As Long
Dim lti As TIMEVAL
' Au moins un octet demandé
If nbRead = 0 Then Exit Function
' délai en secondes
lti.tv_sec = timeout
' une socket à vérifier
lfdr.fd_count = 1
' la socket passée en paramètre
lfdr.fd_array(1) = sock
' la socket est-elle prête?
lret = wselect(0, lfdr, lfdw, lfde, lti)
' Si pas d'erreur et délai non dépassé
If lret > 0 Then
' Si socket prête
If lfdr.fd_count = 1 Then
' Buffer de réception
ReDim lBuffer(1 To nbRead)
' Réception binaire
lret = recv(sock, lBuffer(1), nbRead, 0)
' Redimensionne le buffer en fonction des données reçues
If lret > 0 Then
ReDim Preserve lBuffer(1 To lret)
nbRead = lret
ElseIf lret <= 0 Then
Erase lBuffer
nbRead = 0
End If
End If
Else
nbRead = 0
End If
RecvBinTO = lBuffer
End Function
Cette fonction renvoie un tableau d'octets.
nbRead est la taille des données à lire (1024 octets par défaut).
nbRead est modifié par la fonction et contient ensuite la taille des données effectivement lues.
Il faut appeler cette fonction jusqu'à ce que nbRead soit à 0, c'est-à-dire qu'il n'y a plus de données à lire.
Voici un exemple de téléchargement de fichier :
Function ConnectFTPSansProxy()
Dim lData As WSADATA
Dim lsock As Long
Dim lname As SOCKADDR
Dim lStrToSend As String
Dim lStrToReceive As String
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
' Création d'une socket
lsock = socket(AF_INET, SOCK_STREAM, 0)
If lsock <> -1 Then
lname.sin_family = AF_INET ' famille "classique"
' Le port est généralement 21 pour du FTP
lname.sin_port(1) = 21 \ 256 ' première partie du port
lname.sin_port(2) = 21 Mod 256 ' deuxième partie du port
lname.sin_addr = addrfromhost("monserveurftp") ' adresse du serveur
' Connexion
If Connect(lsock, lname, LenB(lname)) = 0 Then
' Réception des données de connexion
lStrToReceive = RecvStrTOFTP(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
' Envoi du nom d'utilisateur
lStrToSend = "USER monUtilisateur" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTOFTP(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Envoi du mot de passe
lStrToSend = "PASS monMotDePasse" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTOFTP(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Type Binaire
lStrToSend = "TYPE I" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTOFTP(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Mode passif
lStrToSend = "PASV" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTOFTP(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
' Création et connexion d'une socket de données
Dim lsockdata As Long ' socket de données
Dim lnamedata As SOCKADDR ' adresse de la socket de données
lsockdata = socket(AF_INET, SOCK_STREAM, 0)
If lsockdata <> -1 Then
Dim lSplit As Variant ' tableau contenant les données entre parenthèses
Dim lPos1 As Long, lPos2 As Long ' position des parenthèses
lPos1 = InStr(lStrToReceive, "(") ' parenthèse ouvrante
lPos2 = InStr(lPos1, lStrToReceive, ")") ' parenthèse fermante
' récupère les informations d'adresse dans un tableau (indice base 0 par défaut)
lSplit = Split(Mid(lStrToReceive, lPos1 + 1, lPos2 - lPos1 - 1), ",")
lnamedata.sin_family = AF_INET ' famille "classique"
' Le port est généralement 21 pour du FTP
lnamedata.sin_port(1) = lSplit(4) ' première partie du port
lnamedata.sin_port(2) = lSplit(5) ' deuxième partie du port
' adresse du serveur
lnamedata.sin_addr = inet_addr(lSplit(0) & "." & lSplit(1) & "." & _
lSplit(2) & "." & lSplit(3))
' Connexion
If Connect(lsockdata, lnamedata, LenB(lnamedata)) = 0 Then
Debug.Print "connexion réussie à la socket de données" & vbCrLf
End If
End If
' Demande du fichier monfichier.zip
lStrToSend = "RETR monfichier.zip" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception du retour de la commande
lStrToReceive = RecvStrTOFTP(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
' Réception des données et écriture du fichier
Dim f As Integer, sfic As String, lbuffer() As Byte, lNbRead As Long, lTotalByte As Long
sfic = "C:\monfichier.zip" ' fichier à écrire sur le pc
If Len(Dir(sfic)) > 0 Then Kill sfic ' supprime le fichier si existe déjà
' ouvre le fichier sur le PC
f = FreeFile
Open ThisWorkbook.Path & "\officeweb.zip" For Binary As #f
Do
lNbRead = 1024 ' lecture par paquet de 1024 octets
'réception de données
lbuffer = RecvBinTO(lsockdata, lNbRead, 2)
' taille totale
lTotalByte = lTotalByte + lNbRead
' si plus de données à recevoir
If lNbRead = 0 Then Exit Do
' écrit les données dans le fichier
Put #f, , lbuffer
Loop
Close f ' ferme le fichier
Debug.Print "Octets reçus dans le fichier: " & lTotalByte & vbCrLf
End If
' Ferme la socket de données
closesocket lsockdata
' Quitte le serveur
lStrToSend = "quit" & vbCrLf
If SendStrTO(lsock, lStrToSend, 2) Then
Debug.Print "Commande envoyée : " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTOFTP(lsock)
Debug.Print "Octets reçus : " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
Else
Debug.Print "Erreur de connexion n° " & Err.LastDllError
End If
closesocket lsock
End If
WSACleanup
End If
End Function
Avec les sockets, on récupère un buffer en mémoire contenant les données du fichier.
On écrit le fichier sur le disque avec les fonctions intégrées de VBA (open, put...).
X-L-6. Envoyer un fichier (STOR)▲
Pour envoyer un fichier, c'est le même principe avec la commande STOR à la place de RETR.
Bien entendu, au lieu de recevoir des données, on envoie des données à la socket lsockdata.
On peut lire le contenu du fichier à l'aide de l'instruction get de VBA.
X-M. Création d'un serveur▲
Les sockets sont utilisées dans le cadre d'un client/serveur.
Jusqu'ici nous n'avons développé que des clients, les serveurs étant des serveurs FTP ou SMTP sur internet.
Nous allons maintenant développer un petit serveur.
Le serveur se compose également d'un (ou plusieurs) socket(s).
Par contre on n'utilise pas la fonction connect mais les fonctions bind, listen et accept.
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 LongPublic Declare Function getsockname Lib "ws2_32.dll" (ByVal hSocket As Long, ByRef Name As SOCKADDR, ByRef NameLen As Long) As Long
Public Declare Function WSAAddressToString Lib "ws2_32.dll" Alias "WSAAddressToStringA" _
(ByRef lpsaAddress As SOCKADDR, ByVal dwAddressLength As Long, _
ByVal lpProtocolInfo As Long, ByVal lpszAddressString As String, _
ByRef lpdwAddressStringLength As Long) As Long
-bind définit l'adresse et le port d'écoute du serveur (un serveur peut avoir plusieurs adresses IP).
-listen place une socket dans un statut d'écoute (prête à recevoir des connexions).
-accept permet d'accepter ou rejeter une tentative de connexion d'un client.
J'ai ajouté deux autres fonctions :
-getsockname qui permet de trouver les informations d'adresse d'une socket ;
-WSAAddressToString qui permet de trouver une adresse IP "en clair".
WSAAddressToString est disponible à partir de Winsock 2. Pour les versions précédentes, il faut utiliser inet_ntoa qui est un peu plus complexe.
Voici un exemple de module pour un serveur (très simpliste) sur Excel (devrait fonctionner aussi sous Word) :
Option Explicit
Dim ServerSock As Long ' Socket serveur
Dim ClientSocks As FD_SET ' Sockets client
' Vérifie si un client a envoyé des données
Public Function ServerCheckRecv()
Dim fdr As FD_SET, fdw As FD_SET, fde As FD_SET
Dim ti As TIMEVAL
Dim lname As SOCKADDR
Dim sStrToRecv As String
Dim cpt As Long
' Timeout à zéro seconde
ti.tv_sec = 0
' Fait une copie de la structure contenant les clients (fdr est modifiée par wselect)
LSet fdr = ClientSocks
If wselect(0, fdr, fdw, fde, ti) > 0 Then
' Pour chaque client ayant envoyé des données
For cpt = 1 To fdr.fd_count
' Lit les données
sStrToRecv = RecvStrTO(fdr.fd_array(cpt), 0)
' Ecrit les données reçues dans la fenêtre Exécution
If sStrToRecv <> "" Then Debug.Print sStrToRecv
Next
End If
' Relance cette procédure dans une seconde
If ServerSock <> 0 Then Application.OnTime DateAdd("s", 1, Now), "ServerCheckRecv"
End Function
' Vérifie si une connexion est en attente et l'accepte
Public Function ServerCheckAccept()
Dim fdr As FD_SET, fdw As FD_SET, fde As FD_SET
Dim ti As TIMEVAL
Dim lname As SOCKADDR
Dim lConnexionSocket As Long
Dim saddr As String, saddrlen As Long
' Timeout à zéro seconde
ti.tv_sec = 0
fdr.fd_count = 1
' Vérifie la socket serveur pour les connexions en attente
fdr.fd_array(1) = ServerSock
' Si une connexion est en attente
If wselect(0, fdr, fdw, fde, ti) > 0 Then
' Accepte la connexion
' lConnexionSocket est la socket connectée
lConnexionSocket = accept(ServerSock, lname, LenB(lname))
' Ajoute la socket client à la structure ClientSocks
ClientSocks.fd_count = ClientSocks.fd_count + 1
ClientSocks.fd_array(ClientSocks.fd_count) = lConnexionSocket
' Récupère l'adresse de la socket client
saddrlen = 256
saddr = Space(saddrlen)
WSAAddressToString lname, LenB(lname), 0, saddr, saddrlen
saddr = Left(saddr, saddrlen - 1)
' Envoie au client un message de connexion
SendStrTO lConnexionSocket, saddr & " Connected OK"
End If
' Relance cette procédure dans une seconde
If ServerSock <> 0 Then Application.OnTime DateAdd("s", 1, Now), "ServerCheckAccept"
End Function
' Lance le serveur
Function RunServeur()
Dim lData As WSADATA
Dim lname As SOCKADDR
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
' Création d'une socket serveur
ServerSock = socket(AF_INET, SOCK_STREAM, 0)
If ServerSock <> -1 Then
lname.sin_family = AF_INET ' famille "classique"
lname.sin_port(1) = 1025 \ 256 ' première partie du port
lname.sin_port(2) = 1025 Mod 256 ' deuxième partie du port
lname.sin_addr = inet_addr("127.0.0.1") ' adresse de la boucle local
' Lie la socket
If bind(ServerSock, lname, LenB(lname)) = 0 Then
' Place la socket en écoute
' 20 est le nombre maximal de clients en attente de connexion
If listen(ServerSock, 20) = 0 Then
' Exécute les fonctions d'acceptation et de réception dans une seconde
Application.OnTime DateAdd("s", 1, Now), "ServerCheckAccept"
Application.OnTime DateAdd("s", 1, Now), "ServerCheckRecv"
End If
End If
End If
End If
End Function
' Arrête le serveur
Function StopServeur()
Dim cpt As Long
' Ferme toutes les connexions
For cpt = 1 To ClientSocks.fd_count
closesocket ClientSocks.fd_array(cpt)
Next
ClientSocks.fd_count = 0
' Ferme la socket serveur
closesocket ServerSock
ServerSock = 0
' Purge Winsock
WSACleanup
End Function
Les fonctions ServerCheckRecv et ServerCheckAccept sont exécutées périodiquement toutes les secondes grâce à l'instruction OnTime.
Sous Access, on pourrait utiliser la minuterie d'un formulaire.
Démarrez le serveur avec RunServer et arrêtez-le avec StopServeur.
Pour cet exemple, j'ai spécifié l'adresse 127.0.0.1 qui est la boucle locale du PC.
C'est-à-dire que seul le PC sur lequel s'exécute le serveur peut communiquer avec lui.
Vous pouvez mettre l'adresse IP de la carte réseau du PC à la place.
Le client devra alors utiliser cette adresse également.
Remarque : mettez l'élément sin_addr à zéro (0) pour écouter sur toutes les IP de la machine.
Concernant le port d'écoute, j'ai mis arbitrairement 1025 : ce port ne doit pas déjà être utilisé.
On peut mettre le port à 0 pour que la fonction bind recherche elle-même un port libre.
La fonction getsockname permet alors de retrouver le port utilisé : le client devra spécifier ce port à la connexion.
Le serveur seul ne fait rien, il faut développer une partie client.
Ce client devra être un autre fichier Excel exécuté dans une application distincte de celle du serveur.
Créez un nouveau fichier dans le lequel vous copiez le module modWinsock.
Ajoutez ensuite un nouveau module client :
Option Explicit
' Se connecte au serveur
Function RunClient()
Dim lData As WSADATA
Dim lClientSock As Long
Dim lServerName As SOCKADDR
Dim lClientName As SOCKADDR
Dim lstrToRecv As String
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
' Création d'une socket
lClientSock = socket(AF_INET, SOCK_STREAM, 0)
' Adresse de connexion
lServerName.sin_family = AF_INET
lServerName.sin_port(1) = 1025 \ 256
lServerName.sin_port(2) = 1025 Mod 256
lServerName.sin_addr = inet_addr("127.0.0.1")
' Connexion
If Connect(lClientSock, lServerName, LenB(lServerName)) = 0 Then
' Lecture information de la socket client
If getsockname(lClientSock, lClientName, LenB(lClientName)) = 0 Then
Debug.Print "Port socket Client: " & lClientName.sin_port(1) * 256 + lClientName.sin_port(2)
End If
' Lecture de l'information de connexion envoyée par le serveur
lstrToRecv = RecvStrTO(lClientSock)
Debug.Print "Reçu : " & lstrToRecv
End If
' Ferme la socket
closesocket lClientSock
' Purge Winsock
WSACleanup
End If
End Function
Ce client est très simple : il se connecte au serveur et récupère l'information de connexion.
Il se déconnecte ensuite tout de suite.
Notez que ce client pourrait tourner sous Word ou Access par exemple, et se connecter à un serveur sous Excel.
Pour tester, exécutez RunServeur sur une application, et RunClient sur l'autre.
Exécutez ensuite StopServeur pour ne pas laisser tourner le serveur inutilement.
Voici le résultat obtenu côté client :
Port socket Client: 4762
Reçu : 127.0.0.1:4762 Connected OK
Avec getsockname côté client, on a récupéré le port de la socket client.
Ce port est différent de celui du serveur : chaque client a besoin d'un port.
L'information reçue provient du serveur :
Celui-ci récupère l'adresse IP et le port du client grâce à la fonction WSAAddressToString.
Ce client-serveur assez simple permet, je l'espère, de comprendre les bases pour développer des applications plus complexes.
Il est possible de connecter plusieurs clients à un serveur distant et de programmer un chat par exemple.
X-N. Module modWinsock▲
Voici le code du module modWinsock utilisé dans les chapitres précédents :
'***************************************************************************************
'* Procédures pour winsock
'***************************************************************************************
Option Explicit
#If VBA7 Then
DefLngPtr a - Z
#Else
DefLng A-Z
#End If
#If VBA7 Then
Public Declare PtrSafe Function WSAGetLastError Lib "ws2_32.dll" () As Long
Public Declare PtrSafe Function WSAStartup Lib "ws2_32.dll" (ByVal wVersionRequested As Integer, ByRef lpWSAData As WSADATA) As Long
Public Declare PtrSafe Function WSACleanup Lib "ws2_32.dll" () As Long
Public Declare PtrSafe Function socket Lib "ws2_32.dll" (ByVal AddressFamily As Long, ByVal SocketType As Long, ByVal Protocol As Long) As LongPtr
Public Declare PtrSafe Function closesocket Lib "ws2_32.dll" (ByVal hSocket As LongPtr) As Long
Public Declare PtrSafe Function connect Lib "ws2_32.dll" (ByVal hSocket As LongPtr, ByRef Name As SOCKADDR, ByVal NameLen As Long) As Long
Public Declare PtrSafe Function gethostbyname Lib "ws2_32.dll" (ByVal Name As String) As LongPtr
Public Declare PtrSafe Function inet_addr Lib "ws2_32.dll" (ByVal IpAddress As String) As Long
Public Declare PtrSafe Function send Lib "ws2_32.dll" (ByVal hSocket As LongPtr, ByRef buffer As Any, ByVal BufferLength As Long, ByVal flags As Long) As Long
Public Declare PtrSafe Function sendstr Lib "ws2_32.dll" Alias "send" (ByVal hSocket As LongPtr, ByVal buffer As String, ByVal BufferLength As Long, ByVal flags As Long) As Long
Public Declare PtrSafe Function recv Lib "ws2_32.dll" (ByVal hSocket As LongPtr, ByRef buffer As Any, ByVal BufferLength As Long, ByVal flags As Long) As Long
Public Declare PtrSafe Function recvstr Lib "ws2_32.dll" Alias "recv" (ByVal hSocket As LongPtr, ByVal buffer As String, ByVal BufferLength As Long, ByVal flags As Long) As Long
Public Declare PtrSafe Function wselect Lib "ws2_32.dll" Alias "select" (ByVal Reserved As Long, ByRef ReadFds As FD_SET, ByRef WriteFds As FD_SET, ByRef ExceptFds As FD_SET, ByRef timeout As TIMEVAL) As Long
Public Declare PtrSafe Function bind Lib "ws2_32.dll" (ByVal hSocket As LongPtr, ByRef Name As SOCKADDR, ByVal NameLen As Long) As Long
Public Declare PtrSafe Function listen Lib "ws2_32.dll" (ByVal hSocket As LongPtr, ByVal BackLog As Long) As Long
Public Declare PtrSafe Function accept Lib "ws2_32.dll" (ByVal hSocket As LongPtr, ByRef SocketAddress As SOCKADDR, ByRef AddrLen As Long) As Long
Public Declare PtrSafe Function getsockname Lib "ws2_32.dll" (ByVal hSocket As LongPtr, ByRef Name As SOCKADDR, ByRef NameLen As Long) As Long
Public Declare PtrSafe Function WSAAddressToString Lib "ws2_32.dll" Alias "WSAAddressToStringA" _
(ByRef lpsaAddress As SOCKADDR, ByVal dwAddressLength As Long, _
ByVal lpProtocolInfo As Long, ByVal lpszAddressString As String, _
ByRef lpdwAddressStringLength As Long) As Long
Public Declare PtrSafe Function CryptBinaryToString Lib "crypt32.dll" Alias "CryptBinaryToStringA" (ByVal pbBinary As String, ByVal cbBinary As Long, ByVal dwFlags As Long, ByVal pszString As String, ByRef pcchString As Long) As Long
Public Declare PtrSafe Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, Source As Any, ByVal length As LongPtr)
#Else
Public Declare Function WSAGetLastError Lib "ws2_32.dll" () As Long
Public Declare Function WSAStartup Lib "ws2_32.dll" (ByVal wVersionRequested As Integer, ByRef lpWSAData As WSADATA) As Long
Public Declare Function WSACleanup Lib "ws2_32.dll" () As Long
Public Declare Function socket Lib "ws2_32.dll" (ByVal AddressFamily As Long, ByVal SocketType As Long, ByVal Protocol As Long) As Long
Public Declare Function closesocket Lib "ws2_32.dll" (ByVal hSocket As Long) As Long
Public Declare Function connect Lib "ws2_32.dll" (ByVal hSocket As Long, ByRef Name As SOCKADDR, ByVal NameLen As Long) As Long
Public Declare Function gethostbyname Lib "ws2_32.dll" (ByVal Name As String) As Long
Public Declare Function inet_addr Lib "ws2_32.dll" (ByVal IpAddress As String) As Long
Public Declare Function send Lib "ws2_32.dll" (ByVal hSocket As Long, ByRef buffer As Any, ByVal BufferLength As Long, ByVal flags As Long) As Long
Public Declare Function sendstr Lib "ws2_32.dll" Alias "send" (ByVal hSocket As Long, ByVal buffer As String, ByVal BufferLength As Long, ByVal flags As Long) As Long
Public Declare Function recv Lib "ws2_32.dll" (ByVal hSocket As Long, ByRef buffer As Any, ByVal BufferLength As Long, ByVal flags As Long) As Long
Public Declare Function recvstr Lib "ws2_32.dll" Alias "recv" (ByVal hSocket As Long, ByVal buffer As String, ByVal BufferLength As Long, ByVal flags As Long) As Long
Public Declare Function wselect Lib "ws2_32.dll" Alias "select" (ByVal Reserved As Long, ByRef ReadFds As FD_SET, ByRef WriteFds As FD_SET, ByRef ExceptFds As FD_SET, ByRef timeout As TIMEVAL) As Long
Public Declare Function bind Lib "ws2_32.dll" (ByVal hSocket As Long, ByRef Name As SOCKADDR, ByVal NameLen As Long) As Long
Public Declare Function listen Lib "ws2_32.dll" (ByVal hSocket As Long, ByVal BackLog As Long) As Long
Public Declare Function accept Lib "ws2_32.dll" (ByVal hSocket As Long, ByRef SocketAddress As SOCKADDR, ByRef AddrLen As Long) As Long
Public Declare Function getsockname Lib "ws2_32.dll" (ByVal hSocket As Long, ByRef Name As SOCKADDR, ByRef NameLen As Long) As Long
Public Declare Function WSAAddressToString Lib "ws2_32.dll" Alias "WSAAddressToStringA" _
(ByRef lpsaAddress As SOCKADDR, ByVal dwAddressLength As Long, _
ByVal lpProtocolInfo As Long, ByVal lpszAddressString As String, _
ByRef lpdwAddressStringLength As Long) As Long
Public Declare Function CryptBinaryToString Lib "crypt32.dll" Alias "CryptBinaryToStringA" (ByVal pbBinary As String, ByVal cbBinary As Long, ByVal dwFlags As Long, ByVal pszString As String, ByRef pcchString As Long) As Long
Public Declare Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, Source As Any, ByVal length As Long)
#End If
Public Type FD_SET
fd_count As Long
#If VBA7 Then
fd_array(1 To 64) As LongPtr
#Else
fd_array(1 To 64) As Long
#End If
End Type
Public Type TIMEVAL
tv_sec As Long
tv_usec As Long
End Type
#If VBA7 Then
Public Type HOSTENT
hName As LongPtr
hAliases As LongPtr
hAddrType As Integer
hLength As Integer
hAddrList As LongPtr
End Type
#Else
Public Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLength As Integer
hAddrList As Long
End Type
#End If
Public Type SOCKADDR
sin_family As Integer
sin_port(1 To 2) As Byte ' équivalent de u_short
#If VBA7 Then
sin_addr As Long 'structure IN_ADDR
#Else
sin_addr As Long 'structure IN_ADDR
#End If
sin_zero As String * 7
End Type
Public Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription As String * 256
szSystemStatus As String * 128
iMaxSockets As Integer
iMaxUdpDg As Integer
#If VBA7 Then
lpVendorInfo As LongPtr
#Else
lpVendorInfo As Long
#End If
End Type
Public Const AF_INET = 2
Public Const SOCK_STREAM = 1
Public Const CRYPT_STRING_BASE64 = 1
Public Const MSG_DONTWAIT As Long = &H40
' -------------------------------------------------------------
' Donnez un nom de serveur en entrée: par exemple smtp.free.fr
' Retourne un entier long pour utilisation dans sin_addr
' WSAStartup doit être exécuté avant cette fonction
' -------------------------------------------------------------
Public Function addrfromhost(Host As String) As Long
Dim lHostEnt As HOSTENT
Dim lHost
Dim lAddress() As Byte
Dim lHostAddress
' lhost est un pointeur vers une structure HOSTENT
lHost = gethostbyname(Host)
If lHost <> 0 Then
' Déplace le contenu mémoire à l'emplacement du pointeur lHost vers la structure lHostEnt
RtlMoveMemory lHostEnt, ByVal lHost, LenB(lHostEnt)
' Prépare un tableau contenant les 4 parties de l'addresse
ReDim lAddress(1 To lHostEnt.hLength) As Byte
' Récupère le pointeur de l'adresse dans lHostAddress
' hAddrList est un pointeur vers un pointeur
RtlMoveMemory lHostAddress, ByVal lHostEnt.hAddrList, lHostEnt.hLength
' Déplace l'adresse dans le tableau lAddress
RtlMoveMemory lAddress(1), ByVal lHostAddress, lHostEnt.hLength
' Transforme l'adresse (ex : 212.29.48.4) en entier long avec inet_addr
' et retourne cette valeur
addrfromhost = inet_addr(lAddress(1) & "." & lAddress(2) & "." & lAddress(3) & "." & lAddress(4))
End If
End Function
' -----------------------------------------------------------------------------
' Réception de données (String) depuis FTP (attente d'un code suivi d'un espace)
' Cf. RFC 959, section 4.2
' -----------------------------------------------------------------------------
Public Function RecvStrTOFTP(sock, Optional timeout As Long = 15) As String
Dim lBuffer As String
Dim lPos As Long
Dim lcpt As Long
Do
lcpt = lcpt + 1
lBuffer = RecvStrTO(sock, IIf(lcpt = 1, timeout, 1))
If lBuffer = "" Then Exit Do
If lBuffer = "-1" Then
lBuffer = "999 Erreur de socket" & vbCrLf
End If
RecvStrTOFTP = RecvStrTOFTP & lBuffer
If lBuffer Like "### *" Or lBuffer Like "*" & vbCrLf & "#### *" Then
Exit Do
End If
Loop
End Function
' -----------------------------------------------------------------------------
' Réception de données (String) sur une socket sock avec timeout en secondes
' Si retour = -1 => erreur
' -----------------------------------------------------------------------------
Public Function RecvStrTO(sock, Optional timeout As Long = 10) As String
Dim lBuffer As String
Dim lfdr As FD_SET, lfdw As FD_SET, lfde As FD_SET
Dim lret As Long
Dim lti As TIMEVAL
' délai en secondes
lti.tv_sec = timeout
' une socket à vérifier
lfdr.fd_count = 1
' la socket passée en paramètre
lfdr.fd_array(1) = sock
' la socket est-elle prête?
lret = wselect(0, lfdr, lfdw, lfde, lti)
' Si pas d'erreur et délai non dépassé
If lret > 0 Then
' Boucle tant qu'il y a des données
Do
' Si socket prête
If lfdr.fd_count = 1 Then
' Réception
lBuffer = Space(1024)
lret = recvstr(sock, lBuffer, 1024, 0)
' Ajoute les données reçues au résultat
If lret > 0 Then
lBuffer = Left(lBuffer, lret)
RecvStrTO = RecvStrTO & lBuffer
ElseIf lret = 0 Then
Exit Do
ElseIf lret < 0 Then
RecvStrTO = "-1"
Exit Do
End If
End If
' Vérifie s'il y a encore des données à recevoir (avec délai à 1 usec)
lfdr.fd_count = 1
lti.tv_sec = 0
lti.tv_usec = 1
lret = wselect(0, lfdr, lfdw, lfde, lti)
If lret <= 0 Then
Exit Do
End If
Loop
End If
End Function
' -----------------------------------------------------------------------------
' Envoi de données (String) sur une socket sock avec timeout en secondes
' Cette fonction renvoit True si l'envoi est correct
' -----------------------------------------------------------------------------
Public Function SendStrTO(sock, ByVal StrToSend As String, Optional timeout As Long = 10) As Boolean
Dim lBuffer As String
Dim lfdr As FD_SET, lfdw As FD_SET, lfde As FD_SET
Dim lret As Long
Dim lti As TIMEVAL
' délai en secondes
lti.tv_sec = timeout
' une socket à vérifier
lfdw.fd_count = 1
' la socket passée en paramètre
lfdw.fd_array(1) = sock
' la socket est-elle prête?
lret = wselect(0, lfdr, lfdw, lfde, lti)
' Si pas d'erreur et délai non dépassé
If lret > 0 Then
' Boucle tant qu'il y a des données à envoyer
Do
' Si socket prête
If lfdw.fd_count = 1 Then
' Envoi
lret = sendstr(sock, StrToSend, Len(StrToSend), 0)
' Test le retour
If lret = -1 Then
' Erreur
SendStrTO = False
Exit Do
Else
If lret < Len(StrToSend) Then
' Envoi partiel
StrToSend = Mid(StrToSend, lret + 1)
Else
' Envoi terminé
SendStrTO = True
Exit Do
End If
End If
End If
Loop
End If
End Function
' -----------------------------------------------------------------------------
' Codage Base64
' -----------------------------------------------------------------------------
Public Function Base64(ByVal pStr As String) As String
Dim lStrReturn As String
Dim lStrLen As Long
' Récupère la taille nécessaire
Call CryptBinaryToString(pStr, Len(pStr), CRYPT_STRING_BASE64, vbNullString, lStrLen)
If (lStrLen > 0) Then
lStrReturn = Space$(lStrLen - 1) ' on retire le chr(0) final
' Code en Base64
Call CryptBinaryToString(pStr, Len(pStr), CRYPT_STRING_BASE64, lStrReturn, lStrLen - 1)
End If
Base64 = lStrReturn
End Function
' -----------------------------------------------------------------------------
' Réception de données binaire sur une socket sock avec timeout en secondes
' -----------------------------------------------------------------------------
Public Function RecvBinTO(sock, Optional nbRead As Long = 1024, Optional timeout As Long = 10) As Variant
Dim lBuffer() As Byte
Dim lfdr As FD_SET, lfdw As FD_SET, lfde As FD_SET
Dim lret As Long
Dim lti As TIMEVAL
' Au moins un octet demandé
If nbRead = 0 Then Exit Function
' délai en secondes
lti.tv_sec = timeout
' une socket à vérifier
lfdr.fd_count = 1
' la socket passée en paramètre
lfdr.fd_array(1) = sock
' la socket est-elle prête?
lret = wselect(0, lfdr, lfdw, lfde, lti)
' Si pas d'erreur et délai non dépassé
If lret > 0 Then
' Si socket prête
If lfdr.fd_count = 1 Then
' Buffer de réception
ReDim lBuffer(1 To nbRead)
' Réception binaire
lret = recv(sock, lBuffer(1), nbRead, 0)
' Redimensionne le buffer en fonction des données reçues
If lret > 0 Then
ReDim Preserve lBuffer(1 To lret)
nbRead = lret
ElseIf lret <= 0 Then
Erase lBuffer
nbRead = 0
End If
End If
Else
nbRead = 0
End If
RecvBinTO = lBuffer
End Function
' -----------------------------------------------------------------------------
' Envoi de données (Bytes) sur une socket sock avec timeout en secondes
' Cette fonction renvoit True si l'envoi est correct
' -----------------------------------------------------------------------------
Public Function SendBinTO(sock, ByteToSend() As Byte, Optional timeout As Long = 10, Optional pCallBackObject As Object) As Boolean
Dim lfdr As FD_SET, lfdw As FD_SET, lfde As FD_SET
Dim lret As Long
Dim lti As TIMEVAL
Dim lBuffer() As Byte
Dim lTotal As Long
Dim lLeft As Long
Dim lSent As Long
Dim lToSend As Long
Dim lCancel As Boolean, lLog As String
Dim lubound As Long
' Contenu vide
lubound = -1
On Error Resume Next
lubound = UBound(ByteToSend)
On Error GoTo 0
If lubound = -1 Then SendBinTO = True: Exit Function
' délai en secondes
lti.tv_sec = timeout
' une socket à vérifier
lfdw.fd_count = 1
' la socket passée en paramètre
lfdw.fd_array(1) = sock
' la socket est-elle prête?
lret = wselect(0, lfdr, lfdw, lfde, lti)
' Si pas d'erreur et délai non dépassé
If lret > 0 Then
' Si socket prête
If lfdw.fd_count = 1 Then
' Boucle tant qu'il y a des données à envoyer
lTotal = UBound(ByteToSend) - LBound(ByteToSend) + 1
lLeft = UBound(ByteToSend) - LBound(ByteToSend) + 1
lSent = 0
Do
If lLeft >= 1024 * 100& Then
lToSend = 1024 * 100&
Else
lToSend = lLeft
End If
ReDim lBuffer(1 To lToSend)
RtlMoveMemory lBuffer(1), ByteToSend(lSent + LBound(ByteToSend)), lToSend
' Envoi
lret = send(sock, lBuffer(1), lToSend, 0)
' Test le retour
If lret = -1 Then
' Erreur
SendBinTO = False
Exit Do
Else
lSent = lSent + lret
lLeft = lLeft - lret
If Not pCallBackObject Is Nothing Then
lLog = Format(lSent / lTotal, "0%")
If Len(lLog) < 4 Then lLog = Space$(4 - Len(lLog)) & lLog
CallByName pCallBackObject, "FTPTransfertCallBack", VbMethod, lLog, lCancel
If lCancel Then
'GetFile = GetFile & SendCommand("ABOR")
SendBinTO = False
Exit Do
End If
End If
If lLeft <= 0 Then
SendBinTO = True
Exit Do
End If
End If
Loop
End If
End If
End FunctionX-O. Compatibilité avec Office 64 bits▲
À partir d'Access 2010, une version 64 bits d'Office est disponible et demande une adaptation du code : Développer avec Office 64 bits.
Les identifiants de socket notamment doivent être des LongPtr pour Office 64 bits.
Le module modWinsock précédent est compatible 64 bits. ;o)
X-P. Connexion SSL sécurisée▲
Certains serveurs requièrent une connexion SSL sécurisée.
À ce jour, je n'ai pas encore pu passer assez de temps sur le sujet pour aboutir à une connexion sécurisée en VBA.
Une piste serait sans doute d'utiliser la librairie crypt32.dll apparue avec XP.
Le sujet est complexe, le chemin est long...
X-Q. Conclusion Winsock▲
Nous avons vu que Winsock permet de développer des dialogues client-serveur avancés, mais au prix d'efforts de programmation non négligeables.
Les codes donnés dans cet article sont loin d'être aboutis :
- il y a peu de gestion d'erreurs. ;
- il faudrait ajouter de nombreuses fonctions utiles, comme par exemple envoyer une commande et recevoir la réponse en une seule fonction ;
- et un module de classe pour gérer l'objet socket serait fort utile.
De plus nous n'avons utilisé que quelques fonctions de l'API. Il y en a beaucoup d'autres mais je ne les maîtrise pas toutes.