10. 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é.
10-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.
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.
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.
10-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.
10-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.
10-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).
10-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
[.
.
.
]
10-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.
10-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.
10-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.
10-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
'
-----------------------------------------------------------------------------
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
'
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
End
If
End
If
'
Vérifie
s'il
y
a
encore
des
données
à
recevoir
(avec
délai
à
zéro)
lti.
tv_sec
=
0
lRet =
wselect
(0
, lfdr, lfdw, lfde, lti)
'
Si
erreur
ou
délai
dépassé
If
lRet <
=
0
Then
Exit
Do
Loop
End
If
End
Function
'
-----------------------------------------------------------------------------
'
Envoi
de
données
(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
'
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.
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-clés SMTP Telnet.
10-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.
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 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
Function
Base64 est un codage et non un cryptage.
Ce n'est nullement une sécurisation des informations.
Le codage en Base64 avec la fonction CryptBinaryToString ajoute automatiquement un saut de ligne (vbCrLf) en fin de chaîne.
Il ne faut donc pas en ajouter un second lors de l'envoi de la commande.
Voici un exemple d'envoi de mail avec Hotmail :
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
Function
10-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
Function
10-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.
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 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 =
RecvStrTO
(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 =
RecvStrTO
(lsock)
Debug.
Print
"
Octets
reçus
:
"
&
Len
(lStrToReceive) &
vbCrLf
&
lStrToReceive
'
Deuxième
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
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.
10-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 =
RecvStrTO
(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 =
RecvStrTO
(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 =
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
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.
10-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.
10-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 =
RecvStrTO
(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 =
RecvStrTO
(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 =
RecvStrTO
(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 =
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 =
RecvStrTO
(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 =
RecvStrTO
(lsock)
Debug.
Print
"
Octets
reçus
:
"
&
Len
(lStrToReceive) &
vbCrLf
&
lStrToReceive
'
Deuxième
réception
des
données
lStrToReceive =
RecvStrTO
(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 =
RecvStrTO
(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 =
RecvStrTO
(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 =
RecvStrTO
(lsock)
Debug.
Print
"
Octets
reçus
:
"
&
Len
(lStrToReceive) &
vbCrLf
&
lStrToReceive
End
If
'
Récupère
la
liste
sur
la
socket
de
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 =
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
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 :
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.
10-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
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
'
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
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 =
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 =
RecvStrTO
(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 =
RecvStrTO
(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 =
RecvStrTO
(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 =
RecvStrTO
(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 =
RecvStrTO
(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 =
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
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...).
10-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.
10-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
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
-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.
10-N. Module modWinsock▲
Voici le code du module modWinsock utilisé dans les chapitres précédents :
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
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
'
-----------------------------------------------------------------------------
'
Réception
de
données
(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
'
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
End
If
End
If
'
Vérifie
s'il
y
a
encore
des
données
à
recevoir
(avec
délai
à
zéro)
lti.
tv_sec
=
0
lret =
wselect
(0
, lfdr, lfdw, lfde, lti)
'
Si
erreur
ou
délai
dépassé
If
lret <
=
0
Then
Exit
Do
Loop
End
If
End
Function
'
-----------------------------------------------------------------------------
'
Envoi
de
données
(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
'
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
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
'
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
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 : Développer 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 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...
10-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.