VBA et développement Web

Thierry GASPERMENT

Tour d'horizon du développement Web en VBA.

Commentez

- Titre : VBA et développement Web

- Auteur : Thierry GASPERMENT

- Parution : 13 septembre 2011

- Mise à jour : 29 juillet 2014

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

Sommaire

- I. Introduction

- II. Librairies utilisées

- II-A. Microsoft Internet Controls

- II-B. Microsoft XML, vX.X

- II-C. Microsoft HTML Object Library

- II-D. Microsoft WinHTTP Services, vX.X

- II-E. AgControl X.X Type Library (Silverlight)

- III. Contrôles internet

- III-A. Créer un navigateur internet externe à l'application

- III-B. Intégrer un navigateur internet à l'application

- III-B-1. Intégrer un navigateur internet à un formulaire Access

- III-B-2. Intégrer un navigateur internet à un formulaire utilisateur (UserForm)

- III-C. Piloter un navigateur internet

- III-D. Événements d'un navigateur internet

- III-D-1. Événements d'un contrôle WebBrowser

- III-D-2. Événements d'un contrôle InternetExplorer

- IV. Librairie HTML

- IV-A. Parcourir un document HTML

- IV-B. Piloter une page HTML

- IV-C. Événements des éléments d'une page HTML

- IV-D. Modifier dynamiquement une page

- IV-E. Créer un gestionnaire d'événements commun

- V. Librairie XML

- V-A. Créer un fichier XML

- V-A-1. Avec un éditeur texte

- V-A-2. Avec les fonctions de fichiers VBA

- V-A-3. Avec la librairie Microsoft XML

- V-B. Charger un fichier XML

- V-C. Parcourir un fichier XML

- V-D. Télécharger un fichier XML

- V-D-1. Méthode synchrone

- V-D-2. Méthode asynchrone

- VI. Requêtes HTTP (MSXML2 ou WinHTTP)

- VI-A. Ouvrir une connexion

- VI-B. Télécharger un fichier

- VI-C. Télécharger un fichier avec affichage de la progression

- VI-D. Utilisation d'un langage serveur (PHP)

- VI-D-1. Passage de paramètres dans une chaîne

- VI-D-2. Passage de paramètres multiples complexes

- VI-D-3. Envoi (upload) d'un fichier

- VI-D-4. Ouverture vers d'autres possibilités

- VII. Silverlight

- VII-A. Premier fichier XAML

- VII-B. Gérer les erreurs

- VII-C. Contrôles disponibles

- VII-D. Adapater le canevas à la taille de la page

- VII-E. Arranger les contrôles dans une grille

- VII-F. Intégrer la page SilverLight dans un WebBrowser

- VII-G. Piloter la page SilverLight à partir de VBA

- VII-G-1. La librairie AgControl Type Library

- VII-G-2. Atteindre le plugin Silverlight

- VII-G-3. Lire la page Silverlight

- VII-G-4. Modifier la page Silverlight

- VII-G-5. Ajouter dynamiquement un élément à la page Silverlight

- VII-H. Gérer les événements de la page SilverLight à partir de VBA

- VII-H-1. Saisie de texte

- VII-H-2. Gestion de la souris

- VII-I. Dessiner avec la souris

- VII-J. Capture d'écran

- VII-K. Images et Vidéos

- VII-K-1. Images

- VII-K-2. Vidéos

- VII-L. Transformations

- VII-M. Animations

- VII-N. Intégrer le code XAML dans la page HTML : Online XAML

- VII-O. Peut-on utiliser des barres de défilement ?

- VII-P. Conclusion Silverlight

- VIII. API WinInet

- VIII-A. Gestion d'erreurs WinInet

- VIII-B. Sessions HTTP

- VIII-C. Sessions FTP

- VIII-C-1. Sessions FTP sans proxy

- VIII-C-2. Sessions FTP avec proxy

- IX. API URL Monikers (URLDownloadToFile)

- X. API Winsock

- X-A. Module VBA modWinsock

- X-B. Initialiser Winsock

- X-C. Créer une socket

- X-D. Connecter une socket

- X-E. Le port sin_port

- X-F. Le serveur sin_addr

- X-G. Récapitulatif

- X-H. Recevoir des données

- X-I. Envoyer des données

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

- X-K. Envoyer des mails par SMTP

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

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

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

- X-L. Gestion d'un serveur FTP

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

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

- X-L-3. Liste des commandes FTP

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

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

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

- X-M. Création d'un serveur

- X-N. Module modWinsock

- X-O. Compatibilité avec Office 64 bits

- X-P. Connexion SSL sécurisée

- X-Q. Conclusion Winsock

- XI. Autre possibilité d'envoi de mails

- XII. Autres plugins pour navigateur internet

- XIII. Conclusion

- XIV. Remerciements

I - Introduction

Les applications Office ne sont certes pas dédiées à une utilisation avec internet.
Nous pouvons cependant grâce à la programmation VBA créer des passerelles entre internet et Office, en local ou en réseau.

Ce tour d'horizon de développement Web sera loin d'être exhaustif, car le sujet est vaste.

Nous allons écrire beaucoup de code VBA. Un niveau intermédiaire sur ce sujet ne sera pas superflu.

Si vous êtes débutant, commencez au moins par lire cet article : Initiation au VBA Office

II - Librairies utilisées

VBA n'est pas par défaut équipé pour gérer des objets tels qu'un navigateur Internet ou un document XML.
Nous allons donc utiliser différentes librairies dont nous détaillerons l'utilisation dans les chapitres suivants.

À noter :
- à partir de la version 2010, Access dispose d'un contrôle navigateur internet standard ;
- un article à lire pour la gestion du XML à partir d'Office 2007 : Office 2007 et le XML.

Nom

Fichier

Description

SHDocVw

shdocvw.dll

Microsoft Internet Controls

MSXML2

msxmlX.dll

Microsoft XML, vx.x

MSHTML

mshtml.tlb

Microsoft HTML Object Library

WinHttp

winhttp.dll

Microsoft WinHttp Services, version x.x

XcpControlLib

npctrl.dll

AgControl x.x Type Library (Silverlight)

Ces librairies peuvent être ajoutées aux références du projet VBA.
Pour ajouter une référence :
- ouvrez l'éditeur VBA (ALT+F11) ;
- choisissez dans le menu : Outils => Références ... ;
- recherchez la librairie dans la liste puis cochez-la ;
- validez avec le bouton OK.

N'ajoutez bien attendu que les librairies nécessaires.

Une fois ajoutées aux références, les membres (propriétés, méthodes...) de ces librairies sont consultables dans l'Explorateur d'objets.
Affichez cet explorateur par le menu Affichage => Explorateur d'objets ou par le raccourci F2.

Sans ce référencement, les objets sont utilisables mais ils ne sont pas proposés par l'éditeur VBA.
Parfois pratique pour développer sans connaître la version de la librairie qui sera installée, ce mécanisme est connu sous le nom de lien tardif (late binding).
Les objets sont alors déclarés de type Object et aucune instruction n'est vérifiée à la compilation.

En plus de ces librairies, nous utiliserons aussi des API (Application Programming Interface).
Cf. les chapitres API WinInet, API URL Monikers et API Winsock.

II-A - Microsoft Internet Controls

Cette librairie contient les objets :
- Application Internet Explorer : c'est l'application qui s'ouvre quand on exécute Internet Explorer ;
- Navigateur Microsoft (WebBrowser) : ce contrôle ActiveX permet d'intégrer un navigateur dans un formulaire.

Retrouvez les références (propriétés, méthodes...) de ces contrôles sur MSDN (en anglais) : Reference for Visual Basic Developers.

Cette librairie est présente sur le PC si Microsoft Internet Explorer 4.0 (ou plus récent) y est installé.

II-B - Microsoft XML, vX.X

Cette librairie est spécialisée dans le traitement des fichiers XML.
On peut charger un fichier XML et parcourir son arborescence d'objets.
Il est également possible d'y ajouter des éléments et de sauvegarder le fichier.

Une classe très utile (XMLHTTP) de cette librairie permet également d'envoyer des requêtes (GET/POST) pour télécharger une page ou un fichier par exemple.
Cette même classe donne la possibilité d'envoyer des données à un script PHP pour remplir un formulaire et recevoir un résultat en retour.

Pour connaître la version de la librairie XML disponible en fonction de l'OS et des applications installées, rendez-vous sur cette page : Liste des versions de Microsoft XML Parser (MSXML).

II-C - Microsoft HTML Object Library

Cette librairie référence les objets du modèle HTML (document, formulaire, tableau...).
Elle permet de parcourir le contenu d'une page HTML.

Vous trouverez les références (propriétés, méthodes...) (en anglais) de cette librairie sur MSDN : MSHTML Reference.

Cette librairie est présente sur le PC si Microsoft Internet Explorer 4.0 (ou plus récent) y est installé.

II-D - Microsoft WinHTTP Services, vX.X

Cette librairie regroupe les fonctions HTTP des API WinInet.

Vous trouverez les références (propriétés, méthodes...) (en anglais) de cette librairie sur MSDN : WinHttpRequest Object.

Pour connaître la version de la librairie XML disponible en fonction de l'OS et des applications installées, rendez-vous sur cette page : WinHTTP Versions.

II-E - AgControl X.X Type Library (Silverlight)

Cette librairie référence les objets nécessaires à l'utilisation du plugin Silverlight.

III - Contrôles internet

Pour dialoguer avec internet, il paraît naturel de vouloir piloter un navigateur tel qu'Internet Explorer.
Dans cet article, nous n'aborderons que ce navigateur.

III-A - Créer un navigateur internet externe à l'application

Le navigateur se présente en VBA comme un objet de type InternetExplorer.
Cet objet représente un navigateur internet tel qu'il se présente lorsqu'on exécute Internet Explorer.

Pour disposer dans VBA des instructions nécessaires, il faut d'abord ajouter la librairie Microsoft Internet Controls.

Ensuite créez dans l'éditeur VBA un nouveau module de code : Insertion => Module.

Avant de créer le module, je vous conseille de modifier l'option de déclaration des variables :
- dans le menu : Outils => Options... ;
- cochez la case Déclaration des variables obligatoire.

Cela a pour effet d'ajouter en en-tête de chaque nouveau module l'instruction Option Explicit.
Cette instruction impose la déclaration de toutes les variables utilisées dans le code.
En précisant le type exact de toutes nos variables, on évite des conversions inutiles de données.
De plus, sans cette option, il est fréquent de faire des erreurs d'étourderie difficiles à déceler (une faute de frappe dans un nom de variable par exemple).
Il est également possible d'écrire cette instruction Option Explicit manuellement.

Nous allons écrire une petite procédure :

Public Sub CreerNavigateur()

End Sub

Dans cette procédure, commençons par déclarer notre objet navigateur :

Dim oNav As SHDocVw.InternetExplorer

Il n'y parait pas, mais il y a déjà beaucoup à dire sur cette ligne de code.

D'abord vous noterez que notre variable oNav qui contient un objet est préfixée par la lettre o.
Ce n'est pas grand-chose mais il est souvent utile de voir en un coup d'œil sur un code assez complexe de quel type est une variable.
Je vous renvoie à ces deux articles pour plus de détails sur les conventions de nommage des variables :
Descriptif des conventions typographiques du code Visual Basic ;
Convention générale de codage pour la programmation.

Ensuite on sait que l'objet que l'on souhaite créer est défini dans la librairie SHDocVw (Microsoft Internet Controls).
Il suffit alors de taper un point après ce nom de librairie pour avoir la liste de toutes les classes de cette librairie.
On pourrait ne pas préfixer la classe InternetExplorer par sa librairie SHDocVw.
Auquel cas VBA rechercherait dans toutes les références actives du projet une classe de nom InternetExplorer, au risque d'utiliser une classe d'une autre librairie.
À ma connaissance, InternetExplorer n'est pas défini dans une autre librairie qu'on utiliserait fréquemment, et donc le nom de librairie n'est pas ici indispensable.

Si vous n'êtes pas familier avec les variables objets, sachez qu'on a seulement déclaré notre variable oNav pour une utilisation future.
Elle n'est pour l'instant liée à aucun objet, le test oNav is Nothing renvoie Vrai.

Pour créer l'objet, il suffit d'utiliser le mot-clé New.

Set oNav = New SHDocVw.InternetExplorer

Il faut que le type qui suit New soit le même que celui utilisé pour déclarer la variable.

oNav pointe désormais vers un navigateur Internet Explorer.
À noter : ce navigateur est par défaut invisible !
Si vous exécutez le code tel quel, vous allez créer un navigateur qui restera ouvert. On ne pourra le fermer que dans le gestionnaire des tâches.

Garder le navigateur invisible peut être utile pour effectuer un traitement en arrière-plan.
Utilisez alors la méthode Quit de l'objet pour le fermer proprement.

Pour voir le navigateur, définissez sa propriété Visible.

oNav.Visible = True

Exécutez maintenant la procédure (F5 avec le curseur à l'intérieur de la procédure).
Une application Internet Explorer s'ouvre.

Par défaut, aucune page n'est ouverte.
Demandons la navigation vers une page : Google par exemple.
Il suffit d'utiliser la méthode Navigate de notre objet.

oNav.Navigate "http://google.fr"

III-B - Intégrer un navigateur internet à l'application

Le navigateur tel que présenté dans le chapitre précédent s'ouvre dans une fenêtre distincte de l'application Office.
Il est également envisageable d'intégrer un navigateur dans un formulaire.
On parle alors de contrôle ActiveX WebBrowser (ou Navigateur Web).
Pour disposer dans VBA du contrôle et des instructions nécessaires, il faut d'abord ajouter la librairie Microsoft Internet Controls.

La méthode de création du contrôle est légèrement différente selon l'application et le type de formulaire.

III-B-1 - Intégrer un navigateur internet à un formulaire Access

Avec un formulaire Access, le WebBrowser s'intègre dans un cadre d'objet qui contient l'ActiveX.

Insérez un nouveau contrôle ActiveX :
- avant Access 2007 : menu Insertion => Contrôle ActiveX ;
- à partir d'Access 2007 : onglet Création => groupe Contrôles => Contrôle ActiveX.

Recherchez le contrôle Navigateur Web Microsoft (ou Microsoft Web Browser) et placez-le sur le formulaire.
Par défaut le premier contrôle est nommé WebBrowser0 ; nous le renommons en ctlNav par exemple.
Si vous ne l'avez pas déjà fait, la librairie Microsoft Internet Controls est automatiquement sélectionnée dans les références.

Une fois le contrôle créé, on dispose d'un objet de type WebBrowser (ou Navigateur Web) qui se pilote de manière similaire à un objet InternetExplorer.

Nous allons écrire le code de navigation vers Google à l'ouverture du formulaire.

Afficher les propriétés du formulaire :
- avant Access 2007 : menu Affichage => Propriétés... ;
- à partir d'Access 2007 : onglet Création => groupe Outils => Feuille des propriétés.

Sélectionnez l'événement Sur Ouverture, choisissez [Procédure événementielle] dans la liste déroulante et cliquez sur les trois petits points à droite.

La procédure Form_Open est générée ; écrivons notre code à l'intérieur.

Private Sub Form_Open(Cancel As Integer)
Me.ctlNav.Object.Navigate "http://google.fr"
End Sub

Le contrôle ctlNav est un cadre d'objet qui contient l'activeX WebBrowser

Pour atteindre le contrôle WebBrowser, il faut passer par la propriété Object du cadre d'objet.
Object n'étant pas d'un type particulier, il n'y a pas d'autocomplétion.
Pour retrouver cette fonctionnalité bien pratique, il faut déclarer un objet de type WebBrowser et le lier à notre contrôle.

Dim oNav As SHDocVw.WebBrowser
Set oNav = Me.ctlNav.Object
oNav.Navigate "http://google.fr"

Affichez le formulaire pour voir la page affichée dans le WebBrowser.

Seul l'intérieur de la fenêtre est affiché. Les barres d'outils et de statut ne sont pas affichées.

III-B-2 - Intégrer un navigateur internet à un formulaire utilisateur (UserForm)

Pour Excel, Word ou encore PowerPoint, les formulaires disponibles sont appelés des UserForms.
Créez un nouveau formulaire à partir de l'éditeur VBA : menu Insertion => UserForm.
Dans le menu Outils => Contrôles supplémentaires..., recherchez Navigateur Web Microsoft et cochez-le.

Le contrôle WebBrowser est alors disponible dans la boîte à outils (icône globe).
Si la boîte à outils n'est pas affichée, réaffichez-la par le menu : Affichage => Boîte à Outils.

Cliquez sur ce bouton et sélectionnez la zone du formulaire sur laquelle déposer le contrôle.

Par défaut, le premier contrôle est nommé WebBrowser1. Vous pouvez le renommer en ctlNav par exemple dans la Fenêtre Propriétés (F4).

Une fois le contrôle créé, on dispose d'un objet de type WebBrowser qui se pilote de manière similaire à un objet InternetExplorer.

Nous allons écrire le code de navigation vers Google à l'ouverture du formulaire.
Passez en affichage de code (menu Affichage => Code) et sélectionnez dans les listes déroulantes en haut de module :
UserForm à gauche puis Initialize à droite.
La procédure UserForm_Initialize est générée ; écrivons notre code à l'intérieur.

Me.ctlNav.Navigate "http://google.fr"

Affichez le formulaire (F5) pour voir la page affichée dans le WebBrowser.

Seul l'intérieur de la fenêtre est affiché. Les barres d'outils et de statut ne sont pas affichées.

III-C - Piloter un navigateur internet

Les contrôles InternetExplorer et WebBrowser exposent des méthodes utiles à la navigation :
- Navigate pour naviguer vers une adresse ;
- GoBack pour naviguer vers la page précédente ;
- GoForward pour naviguer vers la page suivante ;
- GoHome pour naviguer vers la page d'accueil ;
- Refresh pour rafraîchir la page en cours.

Ces méthodes, associées à des boutons sur le formulaire, permettent une navigation minimale dans un WebBrowser sans avoir besoin du menu complet.
Elles sont également utilisables sur une application InternetExplorer.

III-D - Événements d'un navigateur internet

Les navigateurs exposent différents événements.
Vous trouverez la documentation de ces événements sur MSDN (en anglais) : Reference for Visual BasicDevelopers.

III-D-1 - Événements d'un contrôle WebBrowser

Pour un contrôle WebBrowser, ils sont facilement accessibles dans le code du formulaire.
Sélectionnez d'abord le contrôle dans la liste déroulante en haut à gauche de la page de code (ctlNav par exemple).
Puis choisissez l'événement dans la liste déroulante de droite (DocumentComplete par exemple).

La procédure est automatiquement générée :

Private Sub ctlNav_DocumentComplete(ByVal pDisp As Object, URL As Variant)
End Sub

URL contient l'adresse de la page, pDisp est un objet qui représente le navigateur.
Ajoutons une boîte de message qui s'affichera à chaque chargement de page.

Private Sub ctlNav_DocumentComplete(ByVal pDisp As Object, URL As Variant)
MsgBox "Document chargé" & vbCrLf & URL
End Sub

III-D-2 - Événements d'un contrôle InternetExplorer

Pour un "contrôle" InternetExplorer, on peut accéder aux événements en déclarant ce contrôle avec l'instruction WithEvents.
Il est alors nécessaire que le code soit écrit dans un module de classe (la page code d'un formulaire est aussi un module de classe).

Voici un exemple avec l'événement DocumentComplete.
Ce code est écrit dans le module d'un formulaire contenant un bouton btnNavigue.
Sur clic sur le bouton, on crée un navigateur est on charge la page de recherche Google.

Private WithEvents oNav As SHDocVw.InternetExplorer

Private Sub btnNavigue_Click()
Set oNav = New SHDocVw.InternetExplorer
oNav.Visible = True
oNav.navigate "http://google.fr"
End Sub

Private Sub oNav_DocumentComplete(ByVal pDisp As Object, URL As Variant)
MsgBox "Document chargé" & vbCrLf & URL
End Sub

Le fait de déclarer le navigateur avec WithEvents active les événements et permet de les choisir dans les listes déroulantes en haut de la page de code.

IV - Librairie HTML

Jusqu'ici nous avons navigué sur une page sans regarder son contenu.
Une page internet est codée en langage HTML.
Si vous ne connaissez pas ce langage, vous pouvez consulter ce tutoriel : Les bases du HTML.

Ce langage étant structuré, nous allons lire sa structure à l'aide de la librairie Microsoft HTML Object Library.
Commençons donc par référencer cette librairie dans le menu : Outils => Références ....

IV-A - Parcourir un document HTML

Afin de parcourir un document HTML en provenance d'internet par exemple, il faut d'abord le charger.
Chargeons la page de recherche Google dans un navigateur.
Utilisons pour cela le code vu dans le chapitre précédent :

Public Sub CreerNavigateur()
Dim oNav As SHDocVw.InternetExplorer
Set oNav = New SHDocVw.InternetExplorer
oNav.Visible = True
oNav.navigate "http://google.fr"
End Sub

Cette fonction ouvre Internet Explorer et navigue vers la page de recherche de Google.
Il est également possible d'ouvrir la page dans un contrôle WebBrowser, la suite du code serait identique.

Vous pouvez visualiser la source en cliquant sur la page avec le bouton droit et en choisissant "Afficher la source".
Le code affiché est le code HTML ; il est difficilement exploitable en l'état par code VBA.

En fonction de votre version d'Internet Explorer, vous avez peut-être accès aux outils de développements (dans le menu Outils ou F12).
Cet outil s'avère très pratique pour analyser une page HTML.

Les contrôles navigateurs ont une propriété Document de type Object.
Cette propriété est une passerelle entre la librairie Microsoft Internet Controls et la librairie Microsoft HTML Object Library.
C'est en fait un objet de type HTMLDocument référencé dans la librairie HTML.
Pour profiter de l'autocomplétion de VBA, nous allons déclarer un objet de ce type afin d'y affecter la valeur de cette propriété.

Public Sub CreerNavigateur()
Dim oNav As SHDocVw.InternetExplorer
Dim oDoc As MSHTML.HTMLDocument
Set oNav = New SHDocVw.InternetExplorer
oNav.Visible = True
oNav.navigate "http://google.fr"
Set oDoc = oNav.document
End Sub

Si on exécute le code, on obtient une erreur :

Erreur d'exécution '-2147467259(80004005)':

Erreur Automation
Erreur non spécifiée

Cette erreur est due au fait que l'on essaye de lire la propriété Document avant que celui ne soit chargé.
Il faut donc ajouter une temporisation afin d'attendre le chargement de la page.

Pour vérifier l'état du navigateur, il y a deux propriétés :
- ReadyState : indique l'état de chargement de la page (en cours, chargée...)
- Busy : indique si le navigateur est occupé.

Il est possible que le chargement soit terminé, mais que le navigateur soit toujours occupé à faire diverses tâches.
Nous allons utiliser ces deux propriétés pour nous assurer que tout est bien chargé et que les objets HTML sont tous présents dans l'objet Document.
Une simple boucle suffirait :

While oNav.readyState <> READYSTATE_COMPLETE Or oNav.Busy = True
DoEvents
Wend

Ce code attend que le chargement de la page soit terminé et que le navigateur ne soit plus occupé.
DoEvents peut être nécessaire pour que certains éléments se chargent.
Sans DoEvents, il est possible qu'on reste bloqué dans une boucle sans fin.
Mais comme nous aurons probablement besoin de faire cette même temporisation plusieurs fois, nous allons créer une petite fonction.
Nous en profiterons pour ajouter un timeout qui évitera une boucle sans fin en cas de blocage du navigateur.

' Attend que la page internet soit chargée
' pTimeOut est un time out en secondes (WaitIE vaut True si Timeout)
Public Function WaitIE(oIE As InternetExplorer, Optional pTimeOut As Long = 0) As Boolean
Dim lTimer As Double
lTimer = Timer
Do
DoEvents
If oIE.readyState = READYSTATE_COMPLETE And Not oIE.Busy Then Exit Do
If pTimeOut > 0 And Timer - lTimer > pTimeOut Then
WaitIE = True
Exit Do
End If
Loop
End Function

Cette fonction peut être placée dans n'importe quel module VBA de l'application.
On lui donne en paramètre l'objet Navigateur que l'on veut attendre, et un timeout en secondes.
Si le navigateur n'a pas rendu la main à l'issue du timeout, la fonction renvoie True.

Public Sub CreerNavigateur()
Dim oNav As SHDocVw.InternetExplorer
Dim oDoc As MSHTML.HTMLDocument
Set oNav = New SHDocVw.InternetExplorer
oNav.Visible = True
oNav.navigate "http://google.fr"
' Attente avec timeout de 10 s
If WaitIE(oNav, 10) Then
' 10 s écoulées et page non chargée
MsgBox "Time out!"
Else
' Page chargée, on continue
Set oDoc = oNav.document
End If
End Sub

Cette fonction WaitIE pourra être appelée à chaque navigation.
Si on a précisé un timeout et qu'elle renvoie True, on ne continue pas le traitement.

Sinon, on charge le document dans l'objet oDoc.
Pour visualiser cet objet, placez un point d'arrêt (F9 sur la ligne End If), ou ajoutez une instruction Stop.
Exécutez ensuite la fonction, l'exécution s'arrête.
Affichez la fenêtre Variables Locales : Affichage => Fenêtre Variables Locales.

Vous pouvez naviguer dans l'arborescence de l'objet oDoc.
Chaque élément possède une collection ChildNodes qui permet de visualiser hiérarchiquement tous les objets HTML du document.
Dans la collection All, tous les éléments de l'arborescence sont mis à plat.
Il existe d'autres collections regroupant des objets de même type, par exemple :
forms (formulaires), links (hyperliens), images (images)...

Le nombre d'éléments dans une collection est donné par la propriété Length :
- oDoc.Images.Length => 4
Le premier élément est l'élément d'indice 0 :
- oDoc.Images(0).src => http://www.google.fr/images/close_sm.gif

Pour chercher un élément par son Identifiant, on utilisera la fonction getElementById.
Pour chercher un élément par son Nom, on utilisera la fonction getElementsByName.

IV-B - Piloter une page HTML

Nous souhaitons maintenant remplir la zone de texte à rechercher, puis cliquer sur le bouton de recherche par le code VBA.
Après le chargement de la page, il suffit de chercher la zone de texte dans l'arborescence d'objets et de lui affecter une valeur.
Après analyse du code source de la page, on trouve la zone de recherche :

<input autocomplete=off maxlength=2048 name=q class="lst" title="Recherche Google"
value="" size=57 style="background:#fff;border:1px solid #ccc;border-bottom-color:#999;
border-right-color:#999;color:#000;font:18px
arial,sans-serif bold;margin:0;padding:5px 8px 0 6px;vertical-align:top">

La zone de texte est nommée (name=q), nous pouvons donc faire une recherche par nom.

[...]
' Page chargée, on continue
Set oDoc = oNav.document
' Valeur recherchée
oDoc.getElementsByName("q")(0).Value = "Arkham46"
End If
End Sub

La fonction getElementsByName renvoie un tableau car il pourrait y avoir plusieurs éléments de même nom.
Sur notre page il n'y en a qu'un ; on récupère donc le premier trouvé (indice 0) et on modifie sa valeur.
Pour l'exemple je mets "Arkham46" dans cette zone de recherche.

Ensuite on simule le clic sur le bouton de recherche.
L'élément qui soumet un formulaire est de type submit ; le voici :

<input name=btnG type=submit value="Recherche Google" class=lsb>

Notez qu'il existe un autre bouton de type submit, celui qui correspond à la recherche nommée "J'ai de la chance".

Pour cliquer sur un bouton, il faut exécuter sa méthode Click :

Pour rechercher ce bouton, on peut utiliser la fonction getElementsByName.
Problème ici : avec la version 8 d'Internet Explorer, on se retrouve avec deux boutons de même nom sur la page.

Le code suivant fonctionne avec Internet Explorer 6, mais pas avec Internet Explorer 8 :

' Clic sur bouton
oDoc.getElementsByName("btnG")(0).click

Pour Internet Explorer 8, le bouton recherché est le deuxième (donc d'indice 1) :

' Clic sur bouton
oDoc.getElementsByName("btnG")(1).click

Pour pouvoir facilement retrouver un bouton, on se crée une petite fonction :

' Recherche d'un bouton par son nom dans le document
Private Function GetButton(Document As HTMLDocument, ButtonName As String) As MSHTML.HTMLInputElement
If Document.getElementsByName(ButtonName).length > 1 Then
Set GetButton = Document.getElementsByName(ButtonName)(1)
Else
Set GetButton = Document.getElementsByName(ButtonName)(0)
End If
End Function

Cette fonction renvoie le premier bouton s'il n'y en a qu'un, ou le deuxième s'il y en a plusieurs.

On note ici les problèmes rencontrés lors de l'automatisation d'une page qui n'a pas été prévue pour.
La page peut évoluer et le code est alors à revoir...

Maintenant qu'on sait retrouver le bouton, on clique dessus :

[...]
' Page chargée, on continue
Set oDoc = oNav.document
' Valeur recherchée
oDoc.getElementsByName("q")(0).Value = "Arkham46"
' Clic sur bouton
GetButton(oDoc, "btnG").click
End If
End Sub

Une autre possibilité est de soumettre le formulaire directement avec sa méthode submit sans passer par un bouton.

' Soumettre le formulaire
oDoc.Forms("f").submit

Attention cependant car le clic sur un bouton peut effectuer certaines actions complémentaires qui ne seront pas accomplies par un submit direct.
Dans le doute, simulez le clic sur le bouton voulu.

IV-C - Événements des éléments d'une page HTML

On a vu précédemment que nous avions à notre disposition des événements liés au document.
Il existe aussi des événements pour chacun des éléments de la page.
À titre d'exemple, capturons le clic sur le bouton de recherche de Google.

Reprenons la fonction précédemment écrite, mais en retirant le clic sur le bouton que nous ferons manuellement.
Afin de bénéficier des événements, il faut écrire le code dans un module de classe.
Créons donc un formulaire avec un bouton nommé OpenExplorer.
Sur clic sur ce bouton, on ouvre Internet Explorer sur la page de recherche Google.

Private Sub OpenExplorer_Click()
Dim oNav As SHDocVw.InternetExplorer
Dim oDoc As MSHTML.HTMLDocument
Set oNav = New SHDocVw.InternetExplorer
oNav.Visible = True
oNav.navigate "http://google.fr"
' Attente avec timeout de 10s
If WaitIE(oNav, 10) Then
' 10&#160;s écoulées et page non chargée
MsgBox "Time out!"
Else
' Page chargée, on continue
Set oDoc = oNav.document
End If
End Sub

Nous allons également avoir besoin de la fonction GetButton créée précédemment, collez-la en fin de module par exemple.

Il faut en premier lieu connaître le type de l'élément.
Utilisons TypeName.

[...]
' Page chargée, on continue
Set oDoc = oNav.document
' Bouton Google
MsgBox TypeName(GetButton(oDoc,"btnG"))
End If
End Sub

La boîte de message nous donne le type d'élément nommé btnG : nous avons affaire à un HTMLInputElement.
Ajoutons en en-tête du module une déclaration d'objet de ce type.

Private WithEvents BoutonGoogle As HTMLInputElement

Grâce à l'instruction WithEvents, les événements de cet objet sont disponibles dans les listes déroulantes en haut de la page de code VBA.
Choisissez l'objet BoutonGoogle à gauche et l'événement onclick à droite.
La procédure de traitement du clic sur le bouton est générée :

Private Function BoutonGoogle_onclick() As Boolean

End Function

Vous pouvez alors écrire le code désiré à l'intérieur.
Par exemple l'affichage d'un texte dans la fenêtre Exécution (affichée par CTRL + G) :

Private Function BoutonGoogle_onclick() As Boolean
Debug.Print "Le bouton de recherche est désactivé !"
End Function

L'objet BoutonGoogle est prêt, mais pour l'instant il est vide.
Pour terminer, n'oublions pas d'y affecter le bouton du formulaire après chargement de la page :

[...]
' Page chargée, on continue
Set oDoc = oNav.document
' Bouton Google
Set BoutonGoogle = GetButton(oDoc,"btnG")
End If
End Sub

Nous pouvons tester l'événement en affichant le formulaire.

Notez que par défaut l'événement remplace l'événement standard.
La recherche Google ne s'effectue pas.
Pour que l'événement de clic standard se déclenche, donnez la valeur True au retour de la fonction.

Private Function BoutonGoogle_onclick() As Boolean
Debug.Print "Le bouton de recherche est activé !"
BoutonGoogle_onclick = True
End Function

IV-D - Modifier dynamiquement une page

Nous allons ajouter un bouton de recherche personnalisée, en plus des deux boutons de recherche de Google.
Pour démarrer ce chapitre, on reprend le formulaire avec un bouton OpenExplorer et sa procédure sur clic.

Private Sub OpenExplorer_Click()
Dim oNav As SHDocVw.InternetExplorer
Dim oDoc As MSHTML.HTMLDocument
Set oNav = New SHDocVw.InternetExplorer
oNav.Visible = True
oNav.navigate "http://google.fr"
' Attente avec timeout de 10 s
If WaitIE(oNav, 10) Then
' 10 s écoulées et page non chargée
MsgBox "Time out!"
Else
' Page chargée, on continue
Set oDoc = oNav.document
End If
End Sub

Jetons un coup d'œil à la source ; voici ce qu'on y trouve (légèrement remis en forme) :

<span class=ds >
<span class=lsbb>
<input name=btnG type=submit value="Recherche Google" class=lsb>
</span>
</span>
<span class=ds>
<span class=lsbb>
<input name=btnI type=submit class=lsb value="J'ai de la chance">
</span>
</span>

Dans un premier temps, notre objectif est de rajouter un troisième bouton en suivant le même modèle que les deux existants.
C'est-à-dire : un élément input dans un span lui-même dans un span.
En conservant cette même structure, on aura visuellement un bouton identique aux deux autres.

Voici le code HTML de ce que nous souhaitons ajouter :

<span class=ds >
<span class=lsbb>
<input name=btnA type=submit value="Recherche Arkham46" class=lsb>
</span>
</span>

Le nouveau bouton aura pour nom btnA et pour texte "Recherche Arkham46".
C'est un élément de type submit car il sert à soumettre le formulaire de recherche.

On commence par déclarer trois objets, dont deux au début de la procédure OpenExplorer_Click :

Dim oSpan_ds As MSHTML.HTMLSpanElement
Dim oSpan_lsbb As MSHTML.HTMLSpanElement

Et le troisième (le bouton) au début du module, avec WithEvents, pour avoir accès à ses événements :

Private WithEvents oButton As MSHTML.HTMLInputElement

On a ainsi à disposition un objet pour notre bouton et un objet pour chaque span.
Créons alors nos éléments après chargement du document.

[...]
' Page chargée, on continue
Set oDoc = oNav.document    ' Span
Set oSpan_ds = oDoc.createElement("span")
oSpan_ds.className = "ds"
' Span
Set oSpan_lsbb = oDoc.createElement("span")
oSpan_ds.className = "lsbb"
' Bouton
Set oButton = oDoc.createElement("input")
oButton.Name = "btnA"
oButton.Type = "submit"
oButton.Value = "Recherche Arkham46"
oButton.className = "lsb"
End If
End Sub

On crée d'abord chacun des objets avec CreateElement puis on définit les attributs.
Les éléments sont créés sur l'objet Document.
À leur création ils sont orphelins.
Il faut maintenant les ajouter au bon endroit.

' Ajout du bouton dans le span lsbb
oSpan_lsbb.appendChild oButton
' Ajout du span lsbb dans le span ds
oSpan_ds.appendChild oSpan_lsbb

Afin d'obtenir la hiérarchie définie précédemment, on ajoute le bouton dans le deuxième span, et le deuxième span dans le premier.
Reste à ajouter l'ensemble au bon emplacement, c'est-à-dire après le deuxième bouton existant.

Pour cela on va d'abord rechercher un bouton existant.
Puis on remonte à l'élément parent (avec la méthode ParentElement) : cela nous amène au deuxième span.
On cherche alors le parent une nouvelle fois pour nous mener au premier span.
Le parent de ce dernier est alors l'élément dans lequel on doit ajouter notre élément span contenant le bouton.

' Ajout de l'ensemble
GetButton(oDoc,"btnG").parentElement.parentElement.parentElement.appendChild oSpan_ds

On obtient alors notre troisième bouton :

L'utilisation de appendChild ajoute l'élément à la fin.
Pour insérez un élément à un emplacement défini, il faut utiliser insertBefore ; par exemple :

' Insertion de l'ensemble
GetButton(oDoc,"btnG").parentElement.parentElement.parentElement.insertBefore _
oSpan_ds, GetButton(oDoc,"btnG").parentElement.parentElement

Pour réagir au clic sur ce bouton, choisissez dans les listes déroulantes en haut du module VBA : oButton et onclick.
Dans la procédure, écrivons le code qui remplit automatiquement la zone de recherche.

Private Function oButton_onclick() As Boolean
oButton.document.forms("f").elements("q").Value = "Arkham46"
oButton_onclick = True
End Function

Pour changer, ici on a utilisé les collections forms et elements pour trouver la zone de recherche.
Cela fonctionne correctement car il n'y a qu'un seul formulaire nommé "f", et un seul élément nommé "q".

On n'oublie pas de mettre le retour de la fonction à True pour que l'événement continue.

C'est maintenant terminé : un clic sur le nouveau bouton lance une recherche sur le mot "Arkham46".
Voici le code complet de ce formulaire :

Option Explicit

Private WithEvents oButton As MSHTML.HTMLInputElement

Private Function oButton_onclick() As Boolean
oButton.document.forms("f").elements("q").Value = "Arkham46"
oButton_onclick = True
End Function

Private Sub OpenExplorer_Click()
Dim oNav As SHDocVw.InternetExplorer
Dim oDoc As MSHTML.HTMLDocument
Dim oSpan_ds As MSHTML.HTMLSpanElement
Dim oSpan_lsbb As MSHTML.HTMLSpanElement
Set oNav = New SHDocVw.InternetExplorer
oNav.Visible = True
oNav.navigate "http://google.fr"
' Attente avec timeout de 10 s
If WaitIE(oNav, 10) Then
' 10 s écoulées et page non chargée
MsgBox "Time out!"
Else
' Page chargée, on continue
Set oDoc = oNav.document
' Span
Set oSpan_ds = oDoc.createElement("span")
oSpan_ds.className = "ds"
' Span
Set oSpan_lsbb = oDoc.createElement("span")
oSpan_lsbb.className = "lsbb"
' Bouton
Set oButton = oDoc.createElement("input")
oButton.Name = "btnA"
oButton.Type = "submit"
oButton.Value = "Recherche Arkham46"
oButton.className = "lsb"
' Ajout du bouton dans le span lsbb
oSpan_lsbb.appendChild oButton
' Ajout du span lsbb dans le span ds
oSpan_ds.appendChild oSpan_lsbb
' Ajout de l'ensemble
GetButton(oDoc,"btnG").parentElement.parentElement.parentElement.appendChild oSpan_ds
End If
End Sub

' Recherche d'un bouton par son nom dans le document
Private Function GetButton(Document As HTMLDocument, ButtonName As String) As MSHTML.HTMLInputElement
If Document.getElementsByName(ButtonName).length > 1 Then
Set GetButton = Document.getElementsByName(ButtonName)(1)
Else
Set GetButton = Document.getElementsByName(ButtonName)(0)
End If
End Function

IV-E - Créer un gestionnaire d'événements commun

Maintenant, nous souhaitons réagir au clic sur chacun des trois boutons.
On pourrait déclarer trois objets au début du module, avec WithEvents, et gérer chaque événement indépendamment.
C'est une solution qui fonctionne, mais qui devient vite lourde à gérer lorsqu'on souhaite gérer de nombreux éléments.
Nous allons donc dans ce chapitre voir comment créer un gestionnaire d'événements en VBA.

Voici le code de départ de ce chapitre, dans un formulaire avec un bouton nommé OpenExplorer :

Private Sub OpenExplorer_Click()
Dim oNav As SHDocVw.InternetExplorer
Dim oDoc As MSHTML.HTMLDocument
Dim oSpan_ds As MSHTML.HTMLSpanElement
Dim oSpan_lsbb As MSHTML.HTMLSpanElement
Dim oButton As MSHTML.HTMLInputElement
Set oNav = New SHDocVw.InternetExplorer
oNav.Visible = True
oNav.navigate "http://google.fr"
' Attente avec timeout de 10 s
If WaitIE(oNav, 10) Then
' 10 s écoulées et page non chargée
MsgBox "Time out!"
Else
' Page chargée, on continue
Set oDoc = oNav.Document
' Span
Set oSpan_ds = oDoc.createElement("span")
oSpan_ds.className = "ds"
' Span
Set oSpan_lsbb = oDoc.createElement("span")
oSpan_lsbb.className = "lsbb"
' Bouton
Set oButton = oDoc.createElement("input")
oButton.Name = "btnA"
oButton.Type = "submit"
oButton.Value = "Recherche Arkham46"
oButton.className = "lsb"
' Ajout du bouton dans le span lsbb
oSpan_lsbb.appendChild oButton
' Ajout du span lsbb dans le span ds
oSpan_ds.appendChild oSpan_lsbb
' Ajout de l'ensemble
GetButton(oDoc, "btnG").parentElement.parentElement.parentElement.insertBefore _
oSpan_ds, GetButton(oDoc, "btnG").parentElement.parentElement
End If
End Sub

' Recherche d'un bouton par son nom dans le document
Private Function GetButton(Document As HTMLDocument, ButtonName As String) As MSHTML.HTMLInputElement
If Document.getElementsByName(ButtonName).length > 1 Then
Set GetButton = Document.getElementsByName(ButtonName)(1)
Else
Set GetButton = Document.getElementsByName(ButtonName)(0)
End If
End Function

Ce code ouvre Internet Explorer, navigue sur la page de recherche Google, et ajoute le bouton "Recherche Arkham46".
Par rapport au code précédent, on a supprimé la déclaration de oButton de l'en-tête pour la mettre en local dans la procédure.
Tout l'enjeu est maintenant de pouvoir gérer des événements sans déclarer chacun des éléments en en-tête de module.

Chacun des éléments possède des propriétés définissant le gestionnaire affecté à chaque élément :
Par exemple : onclick, onchange...

S'il est classique de créer un gestionnaire d'événements en JavaScript par exemple, il est moins facile de le faire en VBA.
Mais c'est tout de même possible.
Le gestionnaire est en fait un objet, qui possède une méthode par défaut.
Pour créer un tel objet, il faut ajouter un module de classe : menu Insertion => Module de classe.
Le code de ce module est le suivant :

Option Explicit

Public Event WebEvent()

Public Sub EventFired()
'Attribute EventFired.VB_UserMemId = 0
RaiseEvent WebEvent
End Sub

Il contient :
- un événement WebEvent : c'est cet événement que nous allons récupérer dans notre code.
- une procédure EventFired (son nom est arbitraire) qui est la procédure exécutée lorsqu'un événement est levé.

Sauvegardez ce module, avec le nom WebEvents.

Pour une utilisation dans une application Internet Explorer, il faut que ce module soit public.
Définissez la propriété Instancing du module à 2 - PublicNotCreatable.
Le module peut rester privé si la page est affichée dans un contrôle WebBrowser.

Ensuite il faut définir la procédure EventFired comme procédure par défaut de l'objet.
Pour cela il faut exporter, modifier, puis réimporter le module.

- Exportez le module : menu Fichier => Exporter un fichier....
- Supprimez le module : menu Fichier => Supprimer WebEvents....
- Modifiez le fichier exporté dans un éditeur texte : décommentez la première ligne de la procédure.
- Importez le fichier modifié : menu Fichier => Importer un fichier....

La ligne Attribute EventFired.VB_UserMemId = 0 est prise en compte à l'import, mais n'est pas affichée dans l'éditeur VBA.

Le module WebEvents est prêt.
Pour l'utiliser, il faut déclarer dans le code du formulaire (en en-tête de module) un objet de type WebEvents.
N'oubliez pas l'instruction WithEvents qui permet d'utiliser l'événement WebEvent de l'objet.

Private WithEvents oEvents As WebEvents

Ensuite il faut instancier cet objet, dans la procédure OpenExplorer_Click.
En début de procédure, après les déclarations, ajoutez :

Set oEvents = New WebEvents

L'objet est prêt à servir de gestionnaire d'événements.
Il suffit de l'affecter à la propriété correspondant à l'événement à gérer.
On peut réutiliser le même gestionnaire autant de fois que l'on veut.

En fin de procédure, on affecte l'objet oEvents à chacun des boutons :

[...]
' Affecte le gestionnaire d'événements aux boutons
GetButton(oDoc, "btnG").onclick = oEvents
GetButton(oDoc, "btnI").onclick = oEvents
oButton.onclick = oEvents
End If
End Sub

Notez que pour le bouton personnalisé, on utilise directement la variable oButton car ce bouton ajouté dynamiquement n'est pas retrouvé par la méthode getElementsByName.

Par ce code, on demande à ce qu'un clic sur un bouton déclenche la procédure par défaut de l'objet oEvents.
Cette procédure déclenche alors l'événement WebEvent que nous allons gérer.

Cliquez en haut de la page de code sur oEvents à gauche et sur WebEvent à droite.
La procédure événementielle est générée :

Private Sub oEvents_WebEvent()

End Sub

Écrivons-y une instruction Stop pour tester.
Affichez le formulaire et cliquez sur son bouton OpenExplorer pour ouvrir notre explorateur.
Un clic sur un des boutons nous amène à la procédure oEvents_WebEvent.
Intéressant mais comment savoir quel bouton a été cliqué ?

Pendant la durée d'un événement, l'objet Window du document HTML possède une propriété Event qui contient les informations de l'événement.
Pour pouvoir lire cette propriété il nous faut l'objet document.
Cet objet est l'objet oNav qui est déclaré dans la procédure OpenExplorer_Click et n'est donc pas disponible dans la procédure oEvents_WebEvent.
Déplacez donc sa déclaration en en-tête de module, après la déclaration de oEvents :

Private WithEvents oEvents As WebEvents
Private oDoc As MSHTML.HTMLDocument

oDoc est maintenant accessible dans toutes les procédures du module.

Jetons un œil sur les informations de l'événement.
Toujours avec le point d'arrêt dans oEvents_WebEvent, lancez le navigateur et cliquez sur un bouton.
Revenez à l'éditeur VBA et affichez la fenêtre Variables locales : menu Affichage => Fenêtre Variables Locales.

Naviguez dans l'arborescence : Me => oDoc => parentWindow => event.

Nous constatons que cet objet est de type IHTMLEventObj.

Il contient de nombreuses informations dont l'objet source de l'événement : srcElement.
On voit également le type d'événement ("click") qui pourrait permettre de gérer plusieurs types d'événements dans la procédure.

Dans notre procédure événementielle, on peut alors récupérer l'objet event.

Private Sub oEvents_WebEvent()
Dim oEvent As IHTMLEventObj
Set oEvent = oDoc.parentWindow.event
End Sub

Puis on ajoute du code de traitement de l'événement :

Private Sub oEvents_WebEvent()
Dim oEvent As IHTMLEventObj
Set oEvent = oDoc.parentWindow.event
' Traitement fonction du nom de l'élément
Select Case oEvent.srcElement.getAttribute("name")
Case "btnA" ' Bouton "Recherche Arkham46"
' Inscrit la valeur recherchée
oEvent.srcElement.Document.getElementsByName("q")(0).Value = "Arkham46"
Case "btnG" ' Bouton "Recherche Google"
'
Case "btnI" ' Bouton "J'ai de la chance"
' Désactive ce bouton
oEvent.returnValue = False
End Select
' Ajout du texte du bouton dans la fenêtre exécution
Debug.Print "Click sur " & oEvent.srcElement.getAttribute("value")
End Sub

On récupère les attributs HTML de l'élément avec la méthode getAttribute :
- name est le nom du bouton ;
- value est le texte du bouton.

Si le nom du bouton est "btnA", on écrit le texte de recherche prédéfini "Arkham46".
Pour le bouton "btnI" (bouton 'J'ai de la chance'), on désactive l'événement en donnant la valeur False à returnValue.
Pour le bouton "btnG" (bouton de recherche classique) on ne fait rien de particulier.

On écrit également le texte du bouton cliqué dans la fenêtre Exécution (CTRL+G).

C'est maintenant terminé : le clic sur chacun des boutons est géré dans une seule procédure.
Voici le code complet de ce formulaire :

Option Explicit

Private WithEvents oEvents As WebEvents
Private oDoc As MSHTML.HTMLDocument

Private Sub oEvents_WebEvent()
Dim oEvent As IHTMLEventObj
Set oEvent = oDoc.parentWindow.event
' Traitement fonction du nom de l'élément
Select Case oEvent.srcElement.getAttribute("name")
Case "btnA" ' Bouton "Recherche Arkham46"
' Inscrit la valeur recherchée
oEvent.srcElement.Document.getElementsByName("q")(0).Value = "Arkham46"
Case "btnG" ' Bouton "Recherche Google"
'
Case "btnI" ' Bouton "J'ai de la chance"
' Désactive ce bouton
oEvent.returnValue = False
End Select
' Ajout du texte du bouton dans la fenêtre exécution
Debug.Print "Click sur " & oEvent.srcElement.getAttribute("value")
End Sub

Private Sub OpenExplorer_Click()
Dim oNav As SHDocVw.InternetExplorer
Dim oSpan_ds As MSHTML.HTMLSpanElement
Dim oSpan_lsbb As MSHTML.HTMLSpanElement
Dim oButton As MSHTML.HTMLInputElement
Set oEvents = New WebEvents
Set oNav = New SHDocVw.InternetExplorer
oNav.Visible = True
oNav.navigate "http://google.fr"
' Attente avec timeout de 10 s
If WaitIE(oNav, 10) Then
' 10 s écoulées et page non chargée
MsgBox "Time out!"
Else
' Page chargée, on continue
Set oDoc = oNav.Document
' Span
Set oSpan_ds = oDoc.createElement("span")
oSpan_ds.className = "ds"
' Span
Set oSpan_lsbb = oDoc.createElement("span")
oSpan_lsbb.className = "lsbb"
' Bouton
Set oButton = oDoc.createElement("input")
oButton.Name = "btnA"
oButton.Type = "submit"
oButton.Value = "Recherche Arkham46"
oButton.className = "lsb"
' Ajout du bouton dans le span lsbb
oSpan_lsbb.appendChild oButton
' Ajout du span lsbb dans le span ds
oSpan_ds.appendChild oSpan_lsbb
' Ajout de l'ensemble
GetButton(oDoc, "btnG").parentElement.parentElement.parentElement.insertBefore _
oSpan_ds, GetButton(oDoc, "btnG").parentElement.parentElement
' Affecte le gestionnaire d'événements aux boutons
GetButton(oDoc, "btnG").onclick = oEvents
GetButton(oDoc, "btnI").onclick = oEvents
oButton.onclick = oEvents
End If
End Sub

' Recherche d'un bouton par son nom dans le document
Private Function GetButton(Document As HTMLDocument, ButtonName As String) As MSHTML.HTMLInputElement
If Document.getElementsByName(ButtonName).length > 1 Then
Set GetButton = Document.getElementsByName(ButtonName)(1)
Else
Set GetButton = Document.getElementsByName(ButtonName)(0)
End If
End Function

V - Librairie XML

Pour ce chapitre, ajoutez d'abord une référence à la librairie Microsoft XML.
La version 3.0 suffit pour notre besoin.

Si vous n'avez aucune connaissance XML, vous pouvez d'abord consulter les Cours XML.

V-A - Créer un fichier XML

Un fichier XML est en fait un simple fichier texte formaté selon une norme.
On peut donc écrire ce fichier tout simplement comme n'importe quel fichier texte, ou utiliser les méthodes de la librairie XML.

V-A-1 - Avec un éditeur texte

Il suffit d'ouvrir NotePad, WordPad, ou Word par exemple, et y écrire du code XML :

<?xml version="1.0" encoding="ISO-8859-1"?>
<racine>
<info1>test élément 1</info1>
<info2>test élément 2</info1>
<info>
<subinfo1>test sous-élément 1</subinfo1>
<subinfo2>test sous-élément 2</subinfo2>
</info>
</racine>

Notez la première ligne qui est appelée "Instructions processeurs" (Processing Instruction).
On y définit notamment l'encodage du fichier.

Il ne peut y avoir qu'un seul élément à la racine, que j'ai d'ailleurs appelé racine mais qui pourrait avoir un autre nom.
Tous les éléments sont ajoutés à cette racine.

L'indentation (tabulations) et les retours à la ligne ne sont pas obligatoires.

Le fichier doit être sauvegardé en texte brut.
On donnera au fichier une extension xml plutôt que txt mais l'extension n'est pas obligatoire.

V-A-2 - Avec les fonctions de fichiers VBA

Il est également facile de générer un fichier avec les fonctions standards de VBA.
Il suffit d'écrire le fichier XML comme n'importe quel fichier texte séquentiel.

Function CreateXMLFileVBA()
Dim fic As Integer
fic = FreeFile
Open "C:\XMLFileVBA.xml" For Output As #fic
Print #fic, "<?xml version=""1.0"" encoding=""ISO-8859-1""?>"
Print #fic, "<racine>"
Print #fic, "    <info1>test élément 1</info1>"
Print #fic, "    <info2>test élément 2</info1>"
Print #fic, "    <info>"
Print #fic, "        <subinfo1>test sous-élément 1</subinfo1>"""
Print #fic, "        <subinfo2>test sous-élément 2</subinfo2>"
Print #fic, "    </info>"
Print #fic, "</racine>"
Close #fic
End Function

Notez qu'il faut doubler les guillemets dans la chaîne de caractères.

V-A-3 - Avec la librairie Microsoft XML

Nous avons ici besoin d'un objet DOMDocument.
C'est cet objet qui va représenter notre fichier XML.

Function CreateXMLFileXML()
Dim oXML As MSXML2.DOMDocument
Dim oNode As MSXML2.IXMLDOMNode
Set oXML = New MSXML2.DOMDocument
oXML.Save "C:\XMLFileXML.xml"
End Function

Un objet oNode a également été déclaré. Il servira à créer chacun des nœuds du XML.

Pour sauvegarder le document, il suffit d'appeler sa méthode Save.
La fonction crée pour l'instant un fichier vide.
Nous allons ajouter les éléments avant cette instruction de sauvegarde.
Ajoutez les instructions processeur.

Set oNode = oXML.createProcessingInstruction("xml", "version=""1.0"" encoding=""ISO-8859-1""")
oXML.appendChild oNode

Comme pour un document HTML, on doit d'abord créer un élément (le nœud) puis on l'ajoute au bon emplacement.

Pour créer la racine, nous allons utiliser l'instruction With, la créer et l'ajouter en une ligne.

With oXML.appendChild(oXML.createElement("racine"))
End With

On crée un élément avec CreateElement, c'est en fait un objet de type IXMLDOMElement qui est un type dérivé de IXMLDOMNode.
On l'ajoute directement avec appendChild qui nous renvoie l'objet ajouté.
On a alors accès à l'élément racine entre les instructions With et End With.
Écrire un point à l'intérieur de ces instructions est un appel à cet objet.

On ajoute alors notre élément info1.

With oXML.appendChild(oXML.createElement("racine"))
With .appendChild(oXML.createElement("info1"))
.Text = "test élément 1"
End With
End With

On peut imbriquer les instructions With mais seule la dernière est utilisable.
Le .Text appelle l'élément info1 mais on ne peut remonter jusqu'à la racine.
Si on souhaite appeler l'élément supérieur, on peut utiliser parentNode.

Ajoutez de la même manière les autres éléments :

Function CreateXMLFileXML()
Dim oXML As msxml2.DOMDocument
Dim oNode As msxml2.IXMLDOMNode
Set oXML = New msxml2.DOMDocument
Set oNode = oXML.createProcessingInstruction("xml", "version=""1.0"" encoding=""ISO-8859-1""")
oXML.appendChild oNode
With oXML.appendChild(oXML.createElement("racine"))
With .appendChild(oXML.createElement("info1"))
.Text = "test élément 1"
End With
With .appendChild(oXML.createElement("info2"))
.Text = "test élément 2"
End With
With .appendChild(oXML.createElement("info"))
With .appendChild(oXML.createElement("subinfo1"))
.Text = "test sous-élément 1"
End With
With .appendChild(oXML.createElement("subinfo2"))
.Text = "test sous-élément 2"
End With
End With
End With
oXML.Save "C:\XMLFileXML.xml"
End Function

L'instruction With est très pratique, on note qu'on n'a même pas besoin de l'objet oNode.
Les instructions processeur auraient pu être ajoutées en une ligne sans l'objet oNode qui deviendrait complètement inutile.

Si on ouvre le fichier xml ainsi généré dans un éditeur texte, on remarque que le code n'est pas mis en forme.
Cela n'empêche pas le fichier d'être correct.
Si on souhaite le mettre en forme, il y a la possibilité d'utiliser un objet MXXMLWriter comme expliqué dans cet article : Manipuler des fichiers XML en VBScript avec Xpath

Autre possibilité : ajouter des nœuds de type texte avec des tabulations et des sauts de ligne.
Un texte est créé avec la méthode createTextNode.

Function CreateXMLFileXMLIndent()
Dim oXML As msxml2.DOMDocument
Dim oNode As msxml2.IXMLDOMNode
Set oXML = New msxml2.DOMDocument
Set oNode = oXML.createProcessingInstruction("xml", "version=""1.0"" encoding=""ISO-8859-1""")
oXML.appendChild oNode
With oXML.appendChild(oXML.createElement("racine"))
.appendChild oXML.createTextNode(vbCrLf)
.appendChild oXML.createTextNode(vbTab)
With .appendChild(oXML.createElement("info1"))
.Text = "test élément 1"
End With
.appendChild oXML.createTextNode(vbCrLf)
.appendChild oXML.createTextNode(vbTab)
With .appendChild(oXML.createElement("info2"))
.Text = "test élément 2"
End With
.appendChild oXML.createTextNode(vbCrLf)
.appendChild oXML.createTextNode(vbTab)
With .appendChild(oXML.createElement("info"))
.appendChild oXML.createTextNode(vbCrLf)
.appendChild oXML.createTextNode(vbTab)
.appendChild oXML.createTextNode(vbTab)
With .appendChild(oXML.createElement("subinfo1"))
.Text = "test sous-élément 1"
End With
.appendChild oXML.createTextNode(vbCrLf)
.appendChild oXML.createTextNode(vbTab)
.appendChild oXML.createTextNode(vbTab)
With .appendChild(oXML.createElement("subinfo2"))
.Text = "test sous-élément 2"
End With
.appendChild oXML.createTextNode(vbCrLf)
.appendChild oXML.createTextNode(vbTab)
End With
.appendChild oXML.createTextNode(vbCrLf)
End With
oXML.Save "C:\XMLFileXMLIndent.xml"
End Function

C'est beaucoup de travail pour une mise en forme.
Pour un fichier complexe, on pourra préférer la méthode avec l'objet MXXMLWriter (qui requiert ADODB).
Si la mise en forme n'est pas indispensable, sachez que le fichier xml pourra être parcouru sans problème même si tout est écrit sur la même ligne.

V-B - Charger un fichier XML

Pour lire un fichier xml à partir d'un fichier local, il suffit d'appeler la méthode Load.
La méthode LoadXML sert à charger une chaîne de caractères contenant du code xml.
Par défaut le chargement est asynchrone. Pour attendre la fin du chargement avant que le code ne continue, définissez la propriété asynch.

Écrivons une fonction qui charge notre fichier xml indenté généré précédemment :

Function ReadXMLFileXMLIndent()
Dim oXML As msxml2.DOMDocument
Dim oNode As msxml2.IXMLDOMNode
Set oXML = New msxml2.DOMDocument
oXML.async = False
oXML.Load "C:\XMLFileXMLIndent.xml"
End Function

Nous avons ici aussi besoin d'un objet DOMDocument.
L'objet oNode est prévu pour la suite.

Si vous placez un point d'arrêt à la fin de la fonction et que vous regardez dans la fenêtre Variables locales, vous voyez toute l'arborescence du fichier.

On retrouve dans childNodes les instructions processeur et la racine.
Dans documentElement, on trouve directement l'élément racine et son contenu.

V-C - Parcourir un fichier XML

Pour parcourir les éléments du XML, on peut utiliser la collection childNodes.
Par exemple pour écrire le nom de chaque élément contenu dans la racine :

For Each oNode In oXML.documentElement.childNodes
Debug.Print oNode.baseName
Next

Si on souhaite maintenant parcourir un niveau plus bas, il faut un autre objet, par exemple oSubNode.

Dim oSubNode As msxml2.IXMLDOMNode

On peut ensuite parcourir les fils de chaque élément de la racine.

For Each oNode In oXML.documentElement.childNodes
For Each oSubNode In oNode.childNodes
Debug.Print oSubNode.baseName, oSubNode.Text
Next
Next

On obtient ce résultat :

test élément 1
test élément 2
subinfo1 test sous-élément 1
subinfo2 test sous-élément 2

L'élément info1 par exemple contient un élément texte qui se trouve dans les childNodes.
Si on ne souhaite que voir afficher les sous-éléments, il faut tester le type de nœud.

For Each oNode In oXML.documentElement.childNodes
For Each oSubNode In oNode.childNodes
If TypeOf oSubNode Is MSXML2.IXMLDOMElement Then
Debug.Print oSubNode.baseName, oSubNode.Text
End If
Next
Next

Le résultat obtenu est alors :

subinfo1 test sous-élément 1
subinfo2 test sous-élément 2

Si par exemple nous souhaitons récupérer le texte de l'élément subinfo2, il y a bien plus pratique que de naviguer dans toute l'arborescence niveau par niveau.
Il est en effet possible de chercher un élément grâce à son chemin, nommé XPATH.

Vous trouverez la syntaxe de ces XPATH dans cet article : Tutoriel Xpath.

Pour les utiliser il faut exécuter les méthodes selectNodes ou selectSingleNode :
- selectSingleNode renvoie le premier nœud trouvé ;
- selectNodes renvoie une collection de nœuds que l'on peut parcourir avec For Each ;

Pour trouver directement l'élément subinfo2, on va donc utiliser selectSingleNode.

Set oNode = oXML.selectSingleNode("/racine/info/subinfo1")
Debug.Print oNode.baseName, oNode.Text

La syntaxe est assez simple :
- Un / représente la racine ;
- Chaque / est un niveau.

on peut utiliser le joker * pour rechercher plusieurs éléments :

For Each oNode In oXML.selectNodes("/racine/info/*")
Debug.Print oNode.baseName, oNode.Text
Next

Pour recherche un élément dont le nom est connu et unique dans le xml, utilisez un slash double // :

Set oNode = oXML.selectSingleNode("//subinfo2")
Debug.Print oNode.baseName, oNode.Text

Avec ces fonctions, il est donc très facile de retrouver un élément dans le XML.

V-D - Télécharger un fichier XML

Il peut être utile de télécharger un fichier XML sur un serveur internet (ou intranet).
Pour cela nous utiliserons un objet MSXML2.XMLHTTP.

V-D-1 - Méthode synchrone

On commence par créer notre objet.

Function DownloadXML()
Dim oXMLHTTP As MSXML2.XMLHTTP
Set oXMLHTTP = New MSXML2.XMLHTTP
End Function

Ensuite on demande l'ouverture de la requête en donnant l'emplacement du réseau.

oXMLHTTP.Open "POST", "http://arkham46.developpez.com/articles/office/officeweb/fichiers/XMLFileXMLIndent.xml", False

Utilisez "POST" en premier argument pour être sûr de ne pas utiliser le cache et récupérer la dernière version du serveur.
Remplacez "POST" par "GET" pour utiliser le cache.

En deuxième argument, mettez l'adresse http du fichier.

Le troisième argument (à false) définit une requête synchrone, c'est-à-dire que le code est suspendu en attente du téléchargement complet.

À ce stade, la requête est ouverte mais n'a pas été envoyée au serveur : c'est le rôle de la méthode Send.

oXMLHTTP.send

Au retour de la fonction Send, on peut retrouver dans la propriété ResponseXML le contenu du XML dans un objet DOMDocument.
Pensez à tester le retour, propriété status, qui vaut 200 si la requête a été correctement traitée.
Un dernier test consiste à vérifier le code retour de l'objet ParseError qui est différent de 0 si le XML n'est pas correct.

Ensuite on peut parcourir l'objet XML comme vu auparavant pour un fichier chargé depuis le disque.

Function DownloadXML()
Dim oXMLHTTP As MSXML2.XMLHTTP
Dim oXML As MSXML2.DOMDocument
Dim oNode As MSXML2.IXMLDOMNode
Set oXMLHTTP = New MSXML2.XMLHTTP
oXMLHTTP.Open "POST", "http://arkham46.developpez.com/articles/office/officeweb/fichiers/XMLFileXMLIndent.xml", False
oXMLHTTP.send
If oXMLHTTP.Status = 200 Then
Set oXML = oXMLHTTP.responseXML
If oXML.parseError.errorCode = 0 Then
Set oNode = oXML.selectSingleNode("//subinfo2")
Debug.Print oNode.baseName, oNode.Text
End If
End If
End Function

Cette fonctionnalité peut s'avérer pratique pour par exemple télécharger des informations sur une version d'application.
Plutôt que d'utiliser un fichier texte, on peut donc utiliser un fichier XML bien formaté.

V-D-2 - Méthode asynchrone

La méthode du chapitre précédent attend la fin du téléchargement avant de poursuivre le code.
On peut avoir besoin de lancer un téléchargement en arrière-plan, c'est-à-dire de manière asynchrone.
Pour cela, dans le code précédent, il faut mettre le troisième argument de la méthode open à true.

oXMLHTTP.Open "POST", "http://arkham46.developpez.com/articles/office/officeweb/fichiers/XMLFileXMLIndent.xml", True

Mais on ne peut pas laisser la suite du code dans cet état.
En effet le code se poursuit après l'instruction send alors que le téléchargement n'est pas terminé.
Il serait peu utile de faire une boucle d'attente, autant ouvrir en mode asynchrone si l'on veut attendre.

Il faut définir une procédure qui recevra les événements de changement de statut grâce à la propriété onreadystatechange.

Comme pour le gestionnaire d'événements des éléments d'une page HTML vu dans le chapitre IV-E, nous allons créer un objet chargé de recevoir les événements.

Cet objet devra posséder une méthode par défaut.
Pour créer un tel objet, il faut d'abord ajouter un module de classe : menu Insertion => Module de classe.
Le code de ce module est le suivant :

Option Explicit

Dim oXMLHTTP As MSXML2.XMLHTTP

' Définit l'objet XMLHTTP
Public Property Let XMLHTTP(Value As MSXML2.XMLHTTP)
Set oXMLHTTP = Value
End Property

' Procédure par défaut qui reçoit les événements
Sub OnReadyStateChange()
'Attribute OnReadyStateChange.VB_UserMemId = 0
End Sub

Il contient :
- une propriété XMLHTTP : elle nous permettra de transmettre notre objet XMLHTTP pour l'avoir à disposition dans ce module ;
- une procédure OnReadyStateChange (son nom est arbitraire) qui est la procédure exécutée lorsqu'un événement est levé.

Sauvegardez ce module, avec le nom RequestEvents.

Ensuite il faut définir la procédure OnReadyStateChange comme procédure par défaut de l'objet.
Pour cela il faut exporter, modifier, puis réimporter le module.

- Exportez le module : menu Fichier => Exporter un fichier....
- Supprimez le module : menu Fichier => Supprimer RequestEvents....
- Modifiez le fichier exporté dans un éditeur texte : décommentez la première ligne de la procédure.
- Importez le fichier modifié : menu Fichier => Importer un fichier....

La ligne Attribute OnReadyStateChange.VB_UserMemId = 0 est prise en compte à l'import, mais n'est pas affichée dans l'éditeur VBA.

Le module RequestEvents est prêt.
Pour l'utiliser, il faut déclarer un objet de type RequestEvents dans la procédure de téléchargement.

Dim oRequestEvent As RequestEvents

Ensuite il faut instancier cet objet, après l'instruction open par exemple.

Set oRequestEvent = New RequestEvents

L'objet est prêt à servir de gestionnaire d'événements.
Il suffit de l'affecter à la propriété correspondant à l'événement à gérer.

oXMLHTTP.OnReadyStateChange = oRequestEvent

Ceci est à écrire avant le send, ce qui nous donne la fonction suivante :

Function DownloadXMLAsynch()
Dim oXMLHTTP As MSXML2.XMLHTTP
Dim oXML As MSXML2.DOMDocument
Dim oNode As MSXML2.IXMLDOMNode
Dim oRequestEvent As RequestEvents
Set oXMLHTTP = New MSXML2.XMLHTTP
oXMLHTTP.Open "POST", "http://arkham46.developpez.com/articles/office/officeweb/fichiers/XMLFileXMLIndent.xml", True
Set oRequestEvent = New RequestEvents
oRequestEvent.XMLHTTP = oXMLHTTP
oXMLHTTP.OnReadyStateChange = oRequestEvent
oXMLHTTP.send
End Function

La fonction se déroule complètement avant que le fichier n'ait été téléchargé complètement.
Il suffit de gérer dans le module RequestEvents la lecture du fichier xml lorsque le statut est OK.

' Procédure par défaut qui reçoit les événements
Sub OnReadyStateChange()
'Attribute OnReadyStateChange.VB_UserMemId = 0
Dim oXML As MSXML2.DOMDocument
Dim oNode As MSXML2.IXMLDOMNode
If oXMLHTTP.Status = 200 Then
Set oXML = oXMLHTTP.responseXML
If oXML.parseError.errorCode = 0 Then
Set oNode = oXML.selectSingleNode("//subinfo2")
Debug.Print oNode.baseName, oNode.Text
End If
End If
End Sub

Cette astuce est pratique si le fichier à télécharger est volumineux et si le traitement peut se faire en arrière-plan.

VI - Requêtes HTTP (MSXML2 ou WinHTTP)

MSXML2 et WinHTTP possèdent des objets similaires.

MSXML2.XMLHTTP et WinHttp.WinHttpRequest fonctionnent de manière équivalente pour leur méthode open et send par exemple.
L'objet de la librairie XML possède en plus une propriété responseXML qui est bien sûr absente de l'objet de la librairie WinHTTP.

Par contre la gestion du proxy est différente :
- MSXML2 utilise la configuration par défaut du proxy : dans le registre : HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Internet Settings ;
- WinHTTP n'utilise par défaut aucun proxy.

De plus, WinHTTP.WinHttpRequest possède des événements facilement exploitables.

Pour simplifier l'article, nous écrirons le code qui suit pour la librairie WinHTTP.
Les méthodes utilisées seront les mêmes avec la librairie MSXML2, sauf fonctionnalité non existante.

Le proxy est à paramétrer selon les indications du chapitre suivant pour tous les exemples utilisant WinHTTP.

VI-A - Ouvrir une connexion

Pour MSXML2 c'est facile, nous l'avons vu dans le chapitre précédent.
Cette librairie utilise le paramétrage du proxy par défaut de Windows.

Dim oXMLHTTP As MSXML2.XMLHTTP
Set oXMLHTTP = New MSXML2.XMLHTTP
oXMLHTTP.Open "POST", "http://monurl", False

Pour WinHTTP c'est presque aussi facile.

Dim oWinHTTP As WinHttp.WinHttpRequest
Set oWinHTTP = New WinHttp.WinHttpRequest
oWinHTTP.Open "POST", "http://monurl", False

Si ce code fonctionne à la maison, il ne fonctionnera pas sur un réseau d'entreprise avec un proxy.
Il faut préciser le proxy et éventuellement l'utilisateur et le mot de passe.

Dim oWinHTTP As WinHttp.WinHttpRequest
Set oWinHTTP = New WinHttp.WinHttpRequest
oWinHTTP.setProxy 2, "http=monproxy:8080;https=monproxyssl:443;ftp=monproxyftp:8080"
oWinHTTP.Open "POST", "http://monurl", False
oWinHTTP.SetCredentials "monutilisateur", "monmotdepasse", 1

Deux lignes ont fait leur apparition :
- setProxy définit l'adresse du proxy : il est possible de définir des proxy différents en fonction du protocole (http, ftp...).
Le 2 est la valeur de la constante HTTPREQUEST_PROXYSETTING_PROXY ;
- SetCredentials définit l'utilisateur et le mot de passe : il est possible que ces informations soient optionnelles en fonction de la configuration de votre réseau.
Le 1 est la valeur de la constante HTTPREQUEST_SETCREDENTIALS_FOR_PROXY.

VI-B - Télécharger un fichier

Pour télécharger un fichier, nous allons tout simplement ouvrir une connexion sur ce fichier et récupérer le contenu.
Nous allons télécharger le logo de cet article.

Function DownloadHTTP()
Dim oWinHTTP As WinHttp.WinHttpRequest
Set oWinHTTP = New WinHttp.WinHttpRequest
oWinHTTP.Open "POST", "http://arkham46.developpez.com/articles/office/officeweb/images/logoofficeweb.jpg", False
oWinHTTP.send
End Function

Placez un point d'arrêt à la fin de la fonction et regardez dans la fenêtre Variables locales.
Le contenu du fichier a été placé dans les propriétés response* de l'objet oXMLHTTP.
Ce contenu est incompréhensible car c'est le contenu brut du fichier image.

Nous allons utiliser la propriété responseBody qui est un tableau de bytes.

Cette propriété peut être écrite dans un fichier grâce aux fonctions de fichiers de VBA.

Function DownloadHTTP()
Dim oWinHTTP As WinHttp.WinHttpRequest
Dim fic As Integer
Dim buffer() As Byte
Set oWinHTTP = New WinHttp.WinHttpRequest
oWinHTTP.Open "POST", "http://arkham46.developpez.com/articles/office/officeweb/images/logoofficeweb.jpg", False
oWinHTTP.send
If oWinHTTP.Status = 200 Then
fic = FreeFile
Open "c:\monimage.jpg" For Binary As #fic
buffer = oWinHTTP.responseBody
Put #fic, , buffer
Erase buffer
Close #fic
End If
End Function

On utilise une variable buffer pour transférer temporairement le contenu du fichier car le put écrit le responseBody différemment selon les cas.
Il peut ajouter un descripteur qui rend le fichier corrompu. Utiliser un buffer corrige ce problème.

Autre méthode d'écriture de fichier : Comment faire pour écrire des données dans un fichier à l'aide de WriteFile API.

Voici donc un moyen bien pratique pour télécharger un fichier.
Notez qu'il n'y a malheureusement pas d'état d'avancement du téléchargement avec la librairie MSXML2.
Le chapitre suivant montre comment voir l'état d'avancement d'un téléchargement avec la librairie WinHttp.

Il est cependant possible d'utiliser la technique vue au chapitre V-D-2 pour télécharger un fichier de manière asynchrone avec MSXML2.

VI-C - Télécharger un fichier avec affichage de la progression

Ce chapitre est incompatible avec la librairie MSXML2.

La librairie WinHTTP est requise.

En effet l'objet WinHTTP.WinHttpRequest expose différents événements :
- OnError : une erreur est survenue... ;
- OnResponseStart : la requête commence à alimenter la réponse ;
- OnResponseDataAvailable : des données ont alimenté la réponse (tout ou une partie) ;
- OnResponseFinished : la requête a terminé d'alimenter la réponse.

Pour bénéficier de ces événements, il faut écrire le code dans un module de classe (ou un module d'un formulaire).

Nous allons créer un formulaire de téléchargement :
Créez un nouveau formulaire contenant :
- un bouton btnDownload : ce bouton lancera le téléchargement ;
- une zone de texte txtProgress : cette zone de texte affichera l'avancement.

En remplacement de la zone de texte vous pouvez simuler une barre de progression avec une étiquette colorée dont vous ferez varier la taille.

Un objet WinHttpRequest doit être déclaré en en-tête de module :

Private WithEvents oWinHTTP As WinHTTP.WinHttpRequest

Ensuite sur clic sur le bouton, on lance le téléchargement asynchrone.

Private Sub btnDownload_Click()
Set oWinHTTP = New WinHTTP.WinHttpRequest
oWinHTTP.Open "POST", "http://arkham46.developpez.com/articles/office/officeweb/fichiers/officeweb.zip", True
oWinHTTP.send
End Sub

Ajoutez éventuellement le paramétrage de votre proxy.

J'ai mis ici une adresse d'un fichier en dur, on pourrait la mettre dans une variable ou la lire dans une table Access ou une feuille Excel, ou la récupérer d'une variable selon le besoin.

L'écriture du fichier se fait lorsque la requête est terminée.
Dans les listes déroulantes en haut du module, choisissez oWinHTTP et OnResponseFinished.

Le code d'écriture du fichier dans cet événement est le même que celui vu dans les chapitres précédents :

Private Sub oWinHTTP_OnResponseFinished()
Dim fic As Integer
Dim buffer() As Byte
If oWinHTTP.Status = 200 Then
fic = FreeFile
Open "C:\telechargement.zip" For Binary As #fic
buffer = oWinHTTP.responseBody
Put #fic, , buffer
Erase buffer
Close #fic
End If
End Sub

Autre méthode d'écriture de fichier : Comment faire pour écrire des données dans un fichier à l'aide de WriteFile API.

Le nom du fichier téléchargé peut être différent de celui du serveur.

Le fichier est bien téléchargé, ajoutons maintenant l'affichage de la progression.

Dans les listes déroulantes en haut du module, choisissez oWinHTTP et OnResponseDataAvailable :

Private Sub oWinHTTP_OnResponseDataAvailable(Data() As Byte)

End Sub

Cet événement nous transmet un tableau contenant la partie de la réponse qui vient d'être chargée.
Nous pouvons cumuler la taille de ce tableau pour obtenir la progression du téléchargement.

Pour faire les calculs, nous avons besoin de déclarer deux variables en en-tête de module.

Private TotalSize As Long
Private CurrentSize As Long

- TotalSize est la taille totale à télécharger ;
- CurrentSize est la taille déjà téléchargée.

Dans les listes déroulantes en haut du module, choisissez oWinHTTP et OnResponseStart.
Dans cet événement qui marque le début du téléchargement :
- nous initialisons la taille déjà téléchargée : CurrentSize = 0 ;
- nous lisons la taille totale à télécharger : cette lecture se fait dans l'en-tête de la requête.

Private Sub oWinHTTP_OnResponseStart(ByVal Status As Long, ByVal ContentType As String)
CurrentSize = 0
TotalSize = oWinHTTP.getResponseHeader("Content-Length")
End Sub

On peut maintenant revenir à l'événement OnResponseDataAvailable :

Private Sub oWinHTTP_OnResponseDataAvailable(Data() As Byte)
CurrentSize = CurrentSize + UBound(Data) - LBound(Data) + 1
Me.txtProgress.Value = Format(CurrentSize / TotalSize, "0.00%")
End Sub

On ajoute à la taille téléchargée la taille du tableau de l'événement.
Et on calcule et affiche le pourcentage d'avancement.

Vous pouvez maintenant lancer le téléchargement et voir la progression en pourcentage.

Quelques améliorations sont à prévoir :
- gérer les erreurs dans l'événement onError ;
- gérer les cas éventuels où la taille totale ne serait pas disponible ;
- l'écriture pourrait se faire au fur et à mesure de la réception des données pour pouvoir gérer de très gros fichiers.

Mieux encore, on pourrait créer un module de classe réutilisable pour gérer facilement nos téléchargements.

L'utilisation de cette librairie s'avère en tout cas bien plus aisée que les API WinInet sur lesquelles elle s'appuie.

VI-D - Utilisation d'un langage serveur (PHP)

Pour ce chapitre, nous allons écrire un peu de PHP.
PHP est un langage qui s'exécute sur le serveur, et qui va nous être très utile pour dialoguer entre internet et VBA.

Si vous n'avez aucune connaissance en PHP, vous pouvez consulter les cours PHP.

En résumé :
- un fichier contenant du code php doit être déposé sur un serveur sachant exécuter du php (ce qui est logique...) ;
- vous pouvez tester vos pages php sur votre pc en installant une solution tout en main telle que Wamp ou EasyPhp ;
- il est possible d'écrire du code html et php sur la même page : le php s'exécute sur le serveur, puis le html sur le client ;
- on a pour habitude de mettre l'extension .php à un fichier contenant du php mais ce n'est pas obligatoire ;
- le code php s'intègre entre les balises <?php et ?> ;
- pour écrire à partir de php dans une page html, utilisez echo ;
- une variable php est préfixée par un $ ($mavariable = "toto") ;
- chaque ligne de code doit se terminer par un point-virgule ;
- utilisez // pour une ligne de commentaires ;
- internet regorge de documentations et d'exemples.

Mon choix s'est porté sur PHP car il est largement utilisé (on trouve donc de l'aide facilement) et assez accessible.
On pourrait également dialoguer avec un autre langage, tel que ASP. Ne connaissant pas le sujet, je n'ai développé que PHP dans cet article.

VI-D-1 - Passage de paramètres dans une chaîne

Vous avez sans doute déjà vu des adresses de cette forme :

http://monURL/index.php?data1=valeur1&data2=valeur2

Cela signifie que nous passons deux valeurs à la page :
- data1=valeur1
- data2=valeur2

Écrivons un fichier php1.php contenant ce code :

<?php
// Lecture des variables
$data1 = $_POST['data1'];
$data2 = $_POST['data2'];
// Écriture des variables
echo "$data1\n";
echo "$data2\n";
?>

Comme c'est notre premier code php, nous allons le décortiquer.

D'abord le code php est inséré entre les balises <?php et ?>.
Ensuite on récupère les données avec l'instruction $_POST.
On écrit enfin chaque donnée avec l'instruction echo.
Petite subtilité de php : on peut inclure une variable dans une chaîne de caractères.
Le \n est un retour à la ligne.

Une écriture différente du echo pourrait utiliser l'opérateur de concaténation qui est le point en php :

echo $data1."\n";

Placez ce fichier sur un serveur php.
Pour déposer un fichier sur un serveur, vous pouvez utiliser par exemple FileZilla
J'ai déposé ce fichier ici : https://arkham46.developpez.com/articles/office/officeweb/fichiersphp/php1.php.

Appelons ce fichier avec une requête HTTP :

Function SendPhp1()
Dim oWinHTTP As WinHTTP.WinHttpRequest
Set oWinHTTP = New WinHTTP.WinHttpRequest
oWinHTTP.Open "POST", "http://arkham46.developpez.com/articles/office/officeweb/fichiersphp/php1.php", False
oWinHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
oWinHTTP.send "data1=valeur1&data2=valeur2"
Debug.Print oWinHTTP.responseText
End Function

Si besoin, paramétrez votre proxy comme vu au paragraphe VI-A.

On ouvre toujours une connexion avec open, et on envoie la requête avec send.
Entre les deux, une instruction setRequestHeader a fait son apparition.
On indique avec "application/x-www-form-urlencoded" que l'on va passer des paramètres.
Ces paramètres sont indiqués dans la commande send.
Chacun des paramètres est séparé par un &.

On affiche enfin la réponse du serveur contenue dans responseText.
Cette réponse est ce que nous écrivons en php avec echo.

Exécutez la fonction SendPhp1, le résultat s'affiche dans la fenêtre exécution.

valeur1
valeur2

Peu utile en l'état, le code php peut facilement être modifié pour par exemple écrire un fichier contenant les données, ou les inscrire dans une base de données MySQL par exemple.

Pour finir, on peut essayer d'envoyer des données issues de variables.
On va également insérer un saut de ligne dans une des variables pour tester si ça passe.

Function SendPhp1()
Dim oWinHTTP As WinHTTP.WinHttpRequest
Dim sData1 As String
Dim sData2 As String
Set oWinHTTP = New WinHTTP.WinHttpRequest
oWinHTTP.Open "POST", "http://arkham46.developpez.com/articles/office/officeweb/fichiersphp/php1.php", False
oWinHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
sData1 = "Test" & vbCrLf & "sur 2 lignes"
sData2 = "1 ligne"
oWinHTTP.send "data1=" & sData1 & "&data2=" & sData2
Debug.Print oWinHTTP.responseText
End Function

On a ajouté deux variables sData1 et sData2 qui contiennent du texte.
La variable sData1 contient un saut de ligne (vbcrlf).
On doit alors construire une chaîne de caractères pour insérer nos variables et envoyer le tout avec send.
Exécutez la fonction SendPhp1, le résultat s'affiche dans la fenêtre exécution.

Test
sur 2 lignes
1 ligne

Pas de souci donc pour insérer un saut de ligne.

Essayons à présent de mettre des caractères accentués, dans sData1 par exemple :

sData1 = "Test de caractères accentués"

Le résultat n'est pas correct :

Test de caractÃ?res accentuÃ©s
1 ligne

Il faut dire qu'on n'a rien précisé quant au contenu de la reponse.
Dans le fichier php il faut ajouter un en-tête, juste après le <?php :

<?php
header('Content-Type: text/plain; charset=UTF-8');
[...]

On indique ainsi qu'on retourne un fichier texte brut (text/plain) avec un encodage UTF-8 qui gère correctement les accents.

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

Autre souci possible : mettre des guillemets dans une variable :

sData1 = "Test de ""guillemets"""

Le résultat peut ne pas être correct non plus :

Test de \"guillemets\"
1 ligne

En fonction de l'installation de php, celui-ci peut éventuellement ajouter des caractères d'échappement (\).
Pour les retirer, utilisez en php la fonction stripslashes sur les variables reçues.

<?php
header('Content-Type: text/plain; charset=UTF-8');
// Lecture des variables
$data1 = $_POST['data1'];
$data2 = $_POST['data2'];
if(get_magic_quotes_gpc()) // Si les magic quotes sont activés
{
$data1 = stripslashes($data1);
$data2 = stripslashes($data2);
}
// Écriture des variables
echo "$data1\n";
echo "$data2\n";
?>

Reste un problème si vous souhaitez utiliser un caractère & dans une variable.
Comme c'est un caractère réservé pour la séparation des données, on ne peut pas l'utiliser dans une des valeurs.

VI-D-2 - Passage de paramètres multiples complexes

Plutôt que de passer tous les paramètres sur une même ligne, on peut passer des données structurées.
Il faut utiliser un type de contenu : "multipart/form-data".

Il est alors possible d'envoyer des données de type complexe.
Les valeurs possibles du type de donnée (Content-Type) sont listées ici : MIME Media Types.

On crée une nouvelle fonction SendPhp2 qui est assez proche de la précédente :

Function SendPhp2()
Dim oWinHTTP As WinHTTP.WinHttpRequest
Dim sData1 As String
Dim sData2 As String
Dim sFormData As String
Const csBoundary As String = "A@poXX125"
Set oWinHTTP = New WinHTTP.WinHttpRequest
oWinHTTP.Open "POST", "http://arkham46.developpez.com/articles/office/officeweb/fichiersphp/php1.php", False
oWinHTTP.setRequestHeader "Content-Type", "multipart/form-data; charset=""UTF-8"";boundary=" + csBoundary
sData1 = "Test de ""guillemets"""
sData2 = "caractères spéciaux <$£^??çço ©"
sFormData = ???
oWinHTTP.send sFormData
Debug.Print oWinHTTP.responseText
End Function

Comme toujours on ouvre d'abord une connexion avec open.
On cible pour cet exemple le même fichier php que pour le chapitre précédent.

Le Content-Type de la méthode setRequestHeader a changé, c'est maintenant : multipart/form-data.
On a ajouté également (séparé par un point-virgule) le type de caractères utilisé : UTF-8.
Si on ne précise pas UTF-8, les caractères accentués ne passeront pas.
Il faut ensuite définir une chaîne de séparation des données, appelée boundary.
Cette valeur est arbitraire : il faut juste s'assurer que cette chaîne de caractères n'apparaît pas dans les données.

Ensuite il faut envoyer nos données que nous allons écrire dans la variable texte sFormData.
Ces données doivent être écrites selon un format très précis : W3C Recommendation.

Pour les données que l'on souhaite envoyer, voici ce que doit contenir sFormData :

--A@poXX125
Content-Disposition: form-data; name="data1"
Content-Type: text/plain

Test de "guillemets"
--A@poXX125
Content-Disposition: form-data; name="data2"
Content-Type: text/plain

caractères spéciaux <$£^??çço ©
--A@poXX125--

Chaque valeur commence par la valeur de boundary définie en en-tête de la requête, précédée de deux tirets.
Pour chacune de ces valeurs, il faut définir la disposition (form-data) et le nom de la variable qui sera récupérée en php.
Puis vient le type de contenu, optionnel car text/plain par défaut.
On peut utiliser tout type MIME connu, pourvu qu'on sache le gérer à l'arrivée sur le serveur.

Attention, il faut ensuite un saut de ligne (vbCrLf) avant de mettre le contenu de la donnée.
La fin de la donnée est marquée par une nouvelle valeur boundary précédée par deux tirets.
Ce qui marque en fait le début de la donnée suivante.

Pour la dernière donnée, on marque la fin en ajoutant deux tirets (donc deux tirets avant la boundary et deux tirets après).

On peut facilement écrire ces données dans une variable :

sFormData = "--" & csBoundary & vbCrLf & _
"Content-Disposition: form-data; name=""data1""" & vbCrLf & _
"Content-Type: text/plain" & vbCrLf & _
vbCrLf & _
sData1 & vbCrLf & _
"--" & csBoundary & vbCrLf & _
"Content-Disposition: form-data; name=""data2""" & vbCrLf & _
"Content-Type: text/plain" & vbCrLf & _
vbCrLf & _
sData2 & vbCrLf & _
"--" & csBoundary & "--"

Le serveur nous renvoie nos valeurs (par les echo du php) :

Test de "guillemets"
caractères spéciaux <$£^??çço ©

À noter :
- pas de souci avec cette méthode si la valeur contient un caractère & par exemple ;
- il est toujours indispensable de retirer les slashes avec stripslashes comme vu au chapitre précédent.

Pour une utilisation un peu plus poussée de cette méthode, voir les deux chapitres suivants.

VI-D-3 - Envoi (upload) d'un fichier

Permettre l'envoi d'un fichier au serveur n'est pas sans danger.
Une personne mal intentionnée pourrait envoyer sur votre serveur un fichier contenant du code malveillant.
Il convient donc de prendre certaines précautions.
Voici une page très intéressante sur ce sujet : Secure File Upload Check List With PHP.

Pour des raisons évidentes, je n'ai pas placé le fichier php d'upload sur mon serveur.
Pour tester le code qui suit, vous devrez placer le fichier sur votre serveur php et modifier son adresse dans le code VBA.

Envoyer un fichier sur le serveur avec php peut s'avérer très utile.
Pas besoin d'un accès FTP avec les codes d'accès, il suffit d'un accès à la page php, et un accès en écriture par php sur le répertoire voulu.
Il faudra tout de même faire quelques vérifications pour ne pas laisser l'utilisateur uploader n'importe quoi !

Pour plus d'informations sur l'upload de fichier en php, voici un article très intéressant dont nous allons nous inspirer : Upload de fichiers en PHP.

Cet article explique la création d'un formulaire HTML et le code PHP qui se charge de l'upload.
Notre travail ici sera principalement de remplacer le formulaire HTML par du code VBA.

Pour envoyer un fichier, il faut utiliser un type de contenu "multipart/form-data" comme vu au chapitre précédent :

Function SendFilePhp()
Dim oWinHTTP As WinHTTP.WinHttpRequest
Dim sFormData As String
Const csBoundary As String = "A@poXX125"
Set oWinHTTP = New WinHTTP.WinHttpRequest
oWinHTTP.Open "POST", "http://arkham46.developpez.com/articles/office/officeweb/fichiersphp/phpupload.php", False
oWinHTTP.setRequestHeader "Content-Type", "multipart/form-data; charset=""UTF-8"";boundary=" + csBoundary
sFormData = ???
oWinHTTP.send sFormData
Debug.Print oWinHTTP.responseText
End Function

Le code php est écrit dans un fichier phpupload.php.
Pour commencer, nous allons ajouter une seule ligne dans ce fichier.

<?php print_r($_FILES); ?>

Cette ligne écrit les propriétés des fichiers envoyés.
Cela ne suffit pas à gérer l'upload complet, nous écrirons plus tard la suite du code php.

Reste à remplir le plus gros morceau du code VBA : les données dans sFormData.
Voici la structure de ces données :

--A@poXX125
Content-Disposition: form-data; name="fichier1"; filename="monfichier.ext"
Content-Type: application/octet-stream

... contenu du fichier ...
--A@poXX125--

Ces données doivent être écrites selon un format très précis : W3C Recommendation.

On retrouve la valeur boundary qui délimite les données.

Le nom de notre variable est "fichier1".
On lui précise un nom de fichier avec l'attribut filename.
C'est cet attribut filename qui distingue un upload de fichier d'un simple envoi de données.

Le type de contenu est application/octet-stream, c'est-à-dire un contenu binaire.
Si on connaît le type de contenu envoyé, on peut le préciser ici : par exemple image/gif.

Ensuite vient le contenu du fichier, car le chemin donné dans filename n'est qu'une information et ne demande pas la lecture du contenu du fichier.
Et c'est ici que ça se complique.
On souhaite envoyer un contenu binaire, c'est-à-dire le contenu brut du fichier.
Passer par une variable texte (as String) risque de ne pas conserver ces données à l'état brut.
Nous allons donc utiliser un tableau d'octets :

Function SendFilePhp()
Dim oWinHTTP As WinHTTP.WinHttpRequest
Dim sFormData() As Byte
Dim sFormDataHeader As Variant
Dim sFormDataFile As Variant
Dim sFormDataFooter As Variant
Const csBoundary As String = "A@poXX125"
Const sFileName As String = "C:\monimage.jpg"
Set oWinHTTP = New WinHTTP.WinHttpRequest
oWinHTTP.Open "POST", "http://arkham46.developpez.com/articles/office/officeweb/fichiersphp/phpupload.php", False
oWinHTTP.setRequestHeader "Content-Type", "multipart/form-data; charset=""UTF-8"";boundary=" + csBoundary
sFormData = ???
oWinHTTP.send sFormData
Debug.Print oWinHTTP.responseText
End Function

Le contenu final que nous enverrons au serveur (sFormData) est un tableau (car on a mis des parenthèses).
Il est dynamique, c'est-à-dire qu'on n'a pas indiqué sa taille.
Et il contient des éléments de type Byte (Octet), c'est le plus petit élément disponible en VB.

On a également déclaré trois variables :
- sFormDataHeader : contiendra le contenu avant les données du fichier ;
- sFormDataFile : contiendra le contenu du fichier ;
- sFormDataFooter : contiendra le contenu après les données du fichier.

sFormDataHeader et sFormDataFooter seront des chaînes de caractères.
sFormDataFile sera un tableau d'octets.
Ces trois variables sont déclarées de type Variant, cela nous permettra de les concaténer.

Notez aussi l'ajout d'une constante sFileName qui contient le nom du fichier du PC à uploader.
Nous nous contentons ici d'une simple constante.
Il est toutefois possible d'ouvrir une boîte de dialogue de recherche de fichier :
- avec Les boîtes de dialogues intégrées Excel ;
- avec Les boîtes de dialogues intégrées Access (à partir de 2007) ;
- ou avec des API si la version utilisée n'a pas de boîtes de dialogue intégrées : API GetOpenFileName.

On commence par écrire l'en-tête des données :

sFormDataHeader = "--" & csBoundary & vbCrLf & _
"Content-Disposition: form-data; name=""fichier1"";filename=""" & sFileName & """" & vbCrLf & _
"Content-Type: application/octet-stream" & vbCrLf & _
vbCrLf

Comme nous allons envoyer un tableau d'octets, il ne faut pas qu'il soit au format Unicode (format des chaînes de caractères VB).
On doit donc ajouter une conversion :

sFormDataHeader = StrConv(sFormDataHeader, vbFromUnicode)

Puis on écrit de la même manière la fin des données (ce qu'il y a après le contenu du fichier) :

sFormDataFooter = vbCrLf & _
"--" & csBoundary & "--"
sFormDataFooter = StrConv(sFormDataFooter, vbFromUnicode)

Occupons-nous maintenant des données du fichier.
Nous chargeons le fichier dans un tableau d'octets avec les fonctions de fichier VBA :

' Retourne le contenu brut d'un fichier (tableau d'octets)
Function GetFileBinary(FileName) As Variant
Dim buffer() As Byte
Dim f As Integer
f = FreeFile
Open FileName For Binary As #f
ReDim buffer(1 To LOF(f))
Get #f, , buffer
Close #f
GetFileBinary = buffer
End Function

Cette fonction peut être placée dans le module du formulaire ou dans un module séparé.

On ouvre le fichier avec For Binary pour préciser qu'on va lire le contenu brut et non pas un fichier texte séquentiel.
Le buffer est un tableau d'octets que l'on redimensionne à la taille du fichier avant de le remplir.
On place enfin ce buffer dans le retour de la fonction.

On peut alors ajouter l'écriture des données du fichier dans la variable sFormDataFile :

sFormDataFile = GetFileBinary(sFileName)

Pas de conversion à faire ici, on laisse les données brutes.

Pour finir la construction des données, on concatène le tout :

sFormData = sFormDataHeader & sFormDataFile & sFormDataFooter

La concaténation est possible entre des tableaux d'octets et des chaînes de caractères si les variables sont déclarées en Variant.

Voici la fonction complète :

Function SendFilePhp()
Dim oWinHTTP As WinHTTP.WinHttpRequest
Dim sFormData() As Byte
Dim sFormDataHeader As Variant
Dim sFormDataFile As Variant
Dim sFormDataFooter As Variant
Const csBoundary As String = "A@poXX125"
Const sFileName As String = "C:\monimage.jpg"
Set oWinHTTP = New WinHTTP.WinHttpRequest
oWinHTTP.Open "POST", "http://arkham46.developpez.com/articles/office/officeweb/fichiersphp/phpupload.php", False
oWinHTTP.setRequestHeader "Content-Type", "multipart/form-data; boundary=" + csBoundary

sFormDataHeader = "--" & csBoundary & vbCrLf & _
"Content-Disposition: form-data; name=""fichier1"";filename=""" & sFileName & """" & vbCrLf & _
"Content-Type: application/octet-stream" & vbCrLf & _
vbCrLf
sFormDataHeader = StrConv(sFormDataHeader, vbFromUnicode)
sFormDataFooter = vbCrLf & _
"--" & csBoundary & "--"
sFormDataFooter = StrConv(sFormDataFooter, vbFromUnicode)
sFormDataFile = GetFileBinary(sFileName)

sFormData = sFormDataHeader & sFormDataFile & sFormDataFooter
oWinHTTP.send sFormData
Debug.Print oWinHTTP.responseText
End Function

' Retourne le contenu brut d'un fichier (tableau d'octets)
Function GetFileBinary(FileName) As Variant
Dim buffer() As Byte
Dim f As Integer
f = FreeFile
Open FileName For Binary As #f
ReDim buffer(1 To LOF(f))
Get #f, , buffer
Close #f
GetFileBinary = buffer
End Function

Lorsqu'on l'exécute on récupère ceci dans la fenêtre Exécution :

Array
(
[fichier1] => Array
(
[name] => monimage.jpg
[type] => application/octet-stream
[tmp_name] => /tmp/phplXJMz2
[error] => 0
[size] => 7127
)

)

C'est le contenu de la variable $_FILES renvoyé par le php.

On voit que c'est un tableau (cf. le premier Array) qui contient un fichier ([fichier1]).
Les propriétés de ce fichier sont elles aussi dans un tableau dans lequel on trouve :
- name : le nom du fichier : notez que le chemin n'est pas inclus ;
- type : le type du fichier : c'est ce qu'on a mis dans content-type ;
- tmp_name : le nom temporaire du fichier téléchargé : nous allons nous y intéresser de près ;
- error : un éventuel code d'erreur ;
- size : la taille du fichier.

Le nom temporaire du fichier est très important.
En fait le fichier est uploadé dans un répertoire particulier.
Ce fichier est temporaire, il faut le déplacer ensuite à son emplacement final (sinon il sera détruit).

Pour déplacer un tel fichier, il faut utiliser la fonction php move_uploaded_file :

<?php print_r($_FILES); ?>
<?php
if (move_uploaded_file($_FILES['fichier1']['tmp_name'], $_FILES['fichier1']['name']))
{ echo "Le fichier ". $_FILES['fichier1']['name']. " a été uploadé"; }
else
{ echo "Erreur lors de l'upload"; }

?>

Ici on déplace le fichier 'fichier1' à partir de son emplacement temporaire.
On le déplace dans le même répertoire que le script php.

L'exécution de la fonction SendFilePhp retourne ceci :

Array
(
[fichier1] => Array
(
[name] => monimage.jpg
[type] => application/octet-stream
[tmp_name] => /tmp/phpoXPnTg
[error] => 0
[size] => 7127
)

)
Le fichier monimage.jpg a été uploadé

Le fichier a donc été chargé sur le serveur.

N'oubliez pas de mettre en place des vérifications de sécurité sur le fichier uploadé pour ne pas permettre à chacun d'envoyer n'importe quoi sur votre serveur.
Rapprochez-vous si nécessaire d'un expert php qui saura mieux que moi vous aider sur ce sujet.

VI-D-4 - Ouverture vers d'autres possibilités

Nous savons maintenant envoyer et recevoir des données à l'aide de php.
Pour exploiter ces données, on peut envisager de les stocker dans une base de données MySQL par exemple.
Vous trouverez de la documentation sur le sujet dans les cours mysql pour php.

PHP est également capable d'écrire des fichiers sur le serveur pour stocker les données.
Voici quelques fonctions basiques de gestion de fichiers pour lesquelles vous pouvez facilement trouver de la documentation : fopen, fputs, fclose.

Retrouvez tous les cours php

VII - Silverlight

SilverLight est un plugin pour internet.
Il permet de créer des applications complexes, mais aussi des pages plus simples.

Pour créer une application compilée, il faut installer un environnement de développement.
Tous les outils sont disponibles dans le Centre de développement Silverlight.
De plus, la version express de Visual Web Developper est gratuite.
Une application compilée génère un fichier XAP.
Nous n'allons pas détailler ces applications dans cet article.

Il est également possible d'écrire du code dans un fichier XAML, ce que nous allons développer.
Ce code sera interprété par le plugin Silverlight et ne nécessite rien de plus qu'un éditeur texte (et bien sûr un navigateur web pour le rendu).
Beaucoup de contrôles ne sont pas disponibles dans ce type de fichier.
Les contrôles d'un fichier XAP sont plus nombreux et complexes, mais ils ne sont pas (ou peu) exploitables en VBA.
Ils apparaissent cependant dans le plugin si on exécute le fichier XAP par exemple dans un WebBrowser.
Mais le dialogue entre VBA et les contrôles complexes du fichier XAP à travers le plugin Silverlight est très limité.

Nous allons voir quels contrôles sont disponibles en XAML dans la suite.
Ce sont des contrôles de dessin, d'affichage de texte, des images ou vidéos, et un contrôle de saisie de texte.

Consultez si besoin le forum Silverlight.

VII-A - Premier fichier XAML

Pour débuter : Tutoriel Silverlight

Créez un fichier texte avec l'extension .xaml : nommons-le silver1.xaml.
Ouvrez ce fichier avec un éditeur texte, par exemple WordPad.

Écrivez-y ce code :

<Canvas xmlns="http://schemas.microsoft.com/client/2007">
<Canvas>

Ce code est le minimum requis.

Le code XAML est sensible à la casse, c'est-à-dire que les minuscules et majuscules doivent être scrupuleusement respectées.

Canvas est une surface sur laquelle on va déposer nos autres contrôles : la racine du fichier est obligatoirement un canevas.
L'attribut xmlns est l'espace de noms utilisé par Silverlight.

Pour afficher le résultat, il faut créer une page HTML et y intégrer un pulgin Silverlight.

Un lien intéressant en français : Comment ajouter Silverlight à une page Web à l'aide de HTML

Créez un fichier texte avec l'extension .html : nommons-le silver1.html.
Ouvrez ce fichier avec un éditeur texte, par exemple WordPad.

Écrivez-y ce code :

<HTML>
<body>
<object id="SilverLight1" data="data:application/x-silverlight," type="application/x-silverlight-2"
width="100&#160;%" height="100&#160;%">
<param name="source" value="silver1.xaml"/>
<!-- Display installation image. -->
<a href="http://go.microsoft.com/fwlink/?LinkID=149156&v=4.0.50303.0"
style="text-decoration: none;">
<img src="http://go.microsoft.com/fwlink/?LinkId=161376"
alt="Get Microsoft Silverlight"
style="border-style: none"/>
</a>
</object>
</body>
</HTML>

Ce code est du HTML classique.
On inclut dans des balises HTML, et dans le corps (body) du document, un objet Silverlight.
Cet objet a pour identifiant SilverLight1 : cet identifiant nous sera utile plus tard pour retrouver l'objet en VBA.
Les attributs data et type sont fixes quel que soit le fichier XAML utilisé.
On précise également la taille à 100 % du document. On pourrait y mettre des valeurs en pixels.

Dans l'objet, on ajoute les paramètres avec la balise param.
Le paramètre le plus important est la source qui précise où se situe le code.
Pour notre test, c'est le fichier silver1.xaml créé précédemment.
Ce fichier doit être dans le même répertoire que le fichier silver1.html, à moins de spécifier le chemin.

Au cas où le plugin n'est pas installé, il est utile d'informer l'utilisateur et de lui proposer de télécharger le plugin.
C'est le rôle du code qui suit le commentaire <!-- Display installation image. -->.
Si le plugin n'est pas installé, il s'affiche :

Si le plugin est installé, la page est vide...
Pour le voir, il suffit d'afficher la page silver1.html dans un navigateur web (double-cliquez sur le fichier suffit).
Nous l'intégrerons plus tard dans un contrôle WebBrowser.

L'affichage est vide car le canevas n'a pas de dimensions (ni de couleur de fond) et on n'y a pas ajouté de contrôles.

Nous allons ajouter un texte en haut du canevas :

<Canvas Name="rootcanvas" xmlns="http://schemas.microsoft.com/client/2007">
<TextBlock>Premier écran<LineBreak/>Silverlight</TextBlock>
</Canvas>

Un texte s'écrit avec la balise TextBlock.
Notez le <LineBreak/> qui définit un retour à la ligne.

Pour que les caractères accentués s'affichent correctement, le fichier doit être encodé en UTF-8.
Cet encodage peut être défini à la sauvegarde dans NotePad par exemple.

Pour écrire des caractères spéciaux : How to: Use Special Characters in XAML

Affichez la page HTML, le texte s'affiche en haut à gauche.
Il n'y a pas de couleur de fond, nous verrons par la suite pour colorer le fond.

Si rien ne s'affiche, il y a probablement une erreur : voyez le chapitre suivant.

VII-B - Gérer les erreurs

Il n'y a pas de gestion d'erreurs du code XAML par défaut.
Pour gérer les éventuelles erreurs, il faut ajouter un paramètre à l'objet SilverLight dans la page HTML.

<param name="onerror" value="OnErrorEventHandler" />

On ajoute le paramètre onerror qui a la valeur OnErrorEventHandler.
OnErrorEventHandler est une fonction à définir en JavaScript.
Ajoutons cette fonction au fichier HTML à partir des instructions de cette page : Comment : ajouter Silverlight à une page Web à l'aide de HTML.

Voici donc le code de la page silver1.html :

<HTML>
<script type="text/javascript">

function OnErrorEventHandler(sender, errorArgs)
{
// Create the error message to display.
var errorMsg = "Silverlight Error: \n\n";

// Specify error information common to all errors.
errorMsg += "Error Type:    " + errorArgs.errorType + "\n";
errorMsg += "Error Message: " + errorArgs.errorMessage + "\n";
errorMsg += "Error Code:    " + errorArgs.errorCode + "\n";

// Determine the type of error and add specific error information.
switch(errorArgs.errorType)
{
case "RuntimeError":
// Display properties specific to RuntimeErrorEventArgs.
if (errorArgs.lineNumber != 0)
{
errorMsg += "Line: " + errorArgs.lineNumber + "\n";
errorMsg += "Position: " +  errorArgs.charPosition + "\n";
}
errorMsg += "MethodName: " + errorArgs.methodName + "\n";
break;
case "ParserError":
// Display properties specific to ParserErrorEventArgs.
errorMsg += "Xaml File:      " + errorArgs.xamlFile      + "\n";
errorMsg += "Xml Element:    " + errorArgs.xmlElement    + "\n";
errorMsg += "Xml Attribute:  " + errorArgs.xmlAttribute  + "\n";
errorMsg += "Line:           " + errorArgs.lineNumber    + "\n";
errorMsg += "Position:       " + errorArgs.charPosition  + "\n";
break;
default:
break;
}
// Display the error message.
alert(errorMsg);
}

</script>

<body>
<object id="SilverLight1" data="data:application/x-silverlight," type="application/x-silverlight-2"
width="100&#160;%" height="100&#160;%">
<param name="source" value="silver1.xaml"/>
<param name="onerror" value="OnErrorEventHandler" />
<param name="onresize" value="OnResizeEventHandler" />
<!-- Display installation image. -->
<a href="http://go.microsoft.com/fwlink/?LinkID=149156&v=4.0.50303.0"
style="text-decoration: none;">
<img src="http://go.microsoft.com/fwlink/?LinkId=161376"
alt="Get Microsoft Silverlight"
style="border-style: none"/>
</a>
</object>
</body>
</HTML>

En cas d'erreur, le script affiche une boîte de message.

VII-C - Contrôles disponibles

Les contrôles, ainsi que leurs méthodes et propriétés disponibles, sont répertoriés sur cette page : JavaScript API for Silverlight.
Descendez dans la page jusqu'à Documentation for the JavaScript API.
Les contrôles sont présents (aux côtés d'autres objets) dans Objects Reference.

Nous allons utiliser dans la suite quelques-uns de ces contrôles.

VII-D - Adapater le canevas à la taille de la page

Tout d'abord nous avons remarqué qu'il n'y a pas de fond à la page Silverlight.
Effectivement le canevas a été défini sans taille ni couleur de fond.
Il n'est pas nécessaire de préciser une taille au canevas qui ne sert dans ce cas qu'à positionner les éléments.
Les éléments qui "débordent" du canevas sont quand même affichés.

Deux solutions pour ajouter une couleur de fond :
1 - soit ajouter un paramètre background à l'objet Silverlight de la page HTML.

<param name="background" value="yellow" />

Vous pouvez trouver les couleurs prédéfinies et le codage hexa des couleurs personnalisées par exemple ici : Color Table ;

2 - soit définir une couleur et une taille au canevas dans le fichier XAML :

<Canvas Width="300" Height="300" Background="#50FFFF00" xmlns="http://schemas.microsoft.com/client/2007">

J'ai ici défini une taille de 300x300 pixels, et une couleur de fond jaune (rouge+vert) de canal alpha (transparence) 50.

Retrouvez les couleurs prédéfinies et le codage hexa des couleurs personnalisées : Color, structure.

L'écran affiche la couleur de fond uniquement sur la taille du canevas. Le reste est la couleur de fond de la page internet.

Pour redimensionner le canevas à la taille de la page internet, nous allons écrire une petite fonction JavaScript.
Cette fonction sera appelée par le paramètre onresize de l'objet Silverlight dans la page HTML.
Ajoutez ce paramètre sous le paramètre "source".

<param name="onresize" value="OnResizeEventHandler" />

Écrivons ensuite, toujours dans la page silver1.html, la fonction JavaScript :

<HTML>
<script type="text/javascript">

function OnErrorEventHandler(sender, errorArgs)
{
[...]
}

function OnResizeEventHandler(sender, args)
{
sender.width = sender.gethost().content.actualwidth;
sender.height = sender.gethost().content.actualheight;
}

</script>

La fonction OnResizeEventHandler est à ajouter après la fonction OnErrorEventHandler, juste avant la balise de fin </script>.
Elle est assez simple :
- sender est le canevas racine de l'objet Silverlight ;
- gethost permet de remonter au plugin Silverlight : ne pas oublier les parenthèses pour indiquer que c'est une méthode ;
- On récupère alors la taille de l'objet et on l'affecte au canevas.

Pour que tout cela fonctionne, il faut que notre canevas soit nommé "rootcanvas" dans le fichier silver1.xaml :

<Canvas Name="rootcanvas" Background="#50FFFF00" xmlns="http://schemas.microsoft.com/client/2007">

Pas besoin de définir de dimensions ici, elles seront définies par JavaScript.

Pour parfaire le tout, on peut modifier les marges du corps du document HTML afin qu'il n'y ait plus d'entourage blanc.

<body topmargin="0" leftmargin="0" rightmargin="0" bottommargin="0">

Si vous affichez la page silver1.html, vous obtenez le texte sur fond jaune qui remplit toute la page, même lorsqu'on redimensionne le navigateur.
En effet, l'objet Silverlight est défini avec des dimensions à 100 % : si on redimensionne le navigateur, l'objet Silverlight est redimensionné également.

Pour résumer, voici le code du fichier silver1.xaml :

<Canvas Name="rootcanvas" Background="#50FFFF00" xmlns="http://schemas.microsoft.com/client/2007">
<TextBlock>Premier écran<LineBreak/>Silverlight</TextBlock>
</Canvas>

Et voici le code du fichier silver1.html :

<HTML>
<script type="text/javascript">

function OnErrorEventHandler(sender, errorArgs)
{
// Create the error message to display.
var errorMsg = "Silverlight Error: \n\n";

// Specify error information common to all errors.
errorMsg += "Error Type:    " + errorArgs.errorType + "\n";
errorMsg += "Error Message: " + errorArgs.errorMessage + "\n";
errorMsg += "Error Code:    " + errorArgs.errorCode + "\n";

// Determine the type of error and add specific error information.
switch(errorArgs.errorType)
{
case "RuntimeError":
// Display properties specific to RuntimeErrorEventArgs.
if (errorArgs.lineNumber != 0)
{
errorMsg += "Line: " + errorArgs.lineNumber + "\n";
errorMsg += "Position: " +  errorArgs.charPosition + "\n";
}
errorMsg += "MethodName: " + errorArgs.methodName + "\n";
break;
case "ParserError":
// Display properties specific to ParserErrorEventArgs.
errorMsg += "Xaml File:      " + errorArgs.xamlFile      + "\n";
errorMsg += "Xml Element:    " + errorArgs.xmlElement    + "\n";
errorMsg += "Xml Attribute:  " + errorArgs.xmlAttribute  + "\n";
errorMsg += "Line:           " + errorArgs.lineNumber    + "\n";
errorMsg += "Position:       " + errorArgs.charPosition  + "\n";
break;
default:
break;
}
// Display the error message.
alert(errorMsg);
}

function OnResizeEventHandler(sender, args)
{
sender.width = sender.gethost().content.actualwidth;
sender.height = sender.gethost().content.actualheight;
}
</script>

<body topmargin="0" leftmargin="0" rightmargin="0" bottommargin="0">
<object id="SilverLight1" data="data:application/x-silverlight," type="application/x-silverlight-2"
width="100%" height="100%">
<param name="source" value="silver1.xaml"/>
<param name="onerror" value="OnErrorEventHandler" />
<param name="onresize" value="OnResizeEventHandler" />
<!-- Display installation image. -->
<a href="http://go.microsoft.com/fwlink/?LinkID=149156&v=4.0.50303.0"
style="text-decoration: none;">
<img src="http://go.microsoft.com/fwlink/?LinkId=161376"
alt="Get Microsoft Silverlight"
style="border-style: none"/>
</a>
</object>
</body>
</HTML>

Cette page HTML est réutilisable à loisir : il suffit de modifier la source de l'objet Silverlight1.
Il faut bien sûr nommer le canevas "rootcanvas" pour que la fonction de redimensionnement fonctionne.

VII-E - Arranger les contrôles dans une grille

Cela ne vous a pas échappé, le texte n'est pas centré...
Pour le centrer, c'est plus compliqué qu'on pourrait l'imaginer.

Il y a bien une propriété TextAlignement :

<Canvas Name="rootcanvas" Background="#50FFFF00" xmlns="http://schemas.microsoft.com/client/2007">
<TextBlock TextAlignment="Center">
Premier écran<LineBreak/>Silverlight
</TextBlock>
</Canvas>

Mais voici le résultat :

Le texte n'est pas centré sur le canevas, mais seulement sur sa plus grande ligne.
En effet, le texte est centré sur sa largeur, et sa largeur est déterminée lors de l'écriture du texte.
On voudrait définir sa largeur en fonction de celle du canevas qui le contient, mais on ne peut pas (du moins je ne sais pas).

C'est le contrôle Grid qui va nous sauver.
Nous allons créer une grille d'une seule colonne et de deux lignes.
La première ligne contiendra le texte de titre, et la deuxième ligne un canevas sur lequel nous poursuivrons.
Là où la grille nous sauve, c'est que les éléments que l'on place dans les cellules d'une grille occupent toute la cellule.
On dimensionnera bien sûr la grille pour qu'elle occupe toute la page, un peu comme nous l'avons fait avec le canevas.

Voici le nouveau code du fichier silver1.xaml :

<Canvas Name="rootcanvas" Background="#50FFFF00" xmlns="http://schemas.microsoft.com/client/2007">
<!-- La Grille -->
<Grid Name="rootgrid" ShowGridLines="True">
<!-- Définition des colonnes -->
<Grid.ColumnDefinitions>
<ColumnDefinition Width="*" />
</Grid.ColumnDefinitions>
<!-- Définition des lignes -->
<Grid.RowDefinitions>
<RowDefinition Height="Auto" />
<RowDefinition Height="*" />
</Grid.RowDefinitions>
<!-- Texte d'en-tête dans la première ligne -->
<TextBlock Grid.Row="0" Grid.Column="0" TextAlignment="Center">
Premier écran<LineBreak/>Silverlight
</TextBlock>
<!-- Canvas dans la deuxième ligne -->
<Canvas Name="secondcanvas" Background="#FFDDDD" Grid.Row="1" Grid.Column="0">
<!-- On ajoute d'autres contrôles ici -->
</Canvas>
</Grid>
</Canvas>

Nous avons nommé la grille rootgrid afin de la retrouver facilement par code.
Pour y voir plus clair, on affiche les lignes de la grille avec ShowGridLines="True".

Ensuite on définit les colonnes :
- il n'y a qu'une colonne : le * en largeur (Width) signifie que la colonne prend tout l'espace disponible.

Puis on définit les lignes :
- Première ligne pour l'en-tête : on ne définit pas de hauteur (Height) particulière, "Auto" signifie que la ligne prendra la taille de l'élément qu'elle contient.
Elle s'adaptera donc au texte que nous écrirons dedans.
- Deuxième ligne : le * en hauteur (Height) signifie que la ligne prend tout l'espace restant.

Et enfin on place nos éléments.
Pour chaque élément, il faut préciser la colonne et la ligne dans lesquelles on les place.
La première ligne et la première colonne commencent à l'indice 0.

Dans la première ligne on place notre texte centré.
Dans la deuxième ligne on place un canevas dans lequel on pourra mettre d'autres éléments.
Pour distinguer visuellement ce deuxième canevas, on a défini une couleur différente.

La grille ne va pas par défaut occuper toute la taille du canevas qui la contient.
On va la redimensionner dans la fonction JavaScript OnResizeEventHandler du fichier silver1.html.

function OnResizeEventHandler(sender, args)
{
sender.width = sender.gethost().content.actualwidth;
sender.height = sender.gethost().content.actualheight;
sender.findname("rootgrid").width = sender.gethost().content.actualwidth;
sender.findname("rootgrid").height = sender.gethost().content.actualheight;
}

Après avoir redimensionné le canevas racine, on redimensionne la grille nommée rootgrid.
Pour retrouver la grille, appelez FindName sur le sender (notre canevas).

Voici le résultat obtenu :

Le texte est enfin centré.
On voit bien en rose le deuxième canevas qui occupe toute sa cellule.
Si on redimensionne le navigateur, tout le contenu est redimensionné.

À noter : les lignes de la grille ne sont disponibles qu'en pointillés. Cela est prévu à des fins de débogage uniquement.
Pour utiliser d'autres types de traits, il faut mettre chacun des éléments dans un élément Border.
Par exemple, pour encadrer le deuxième canevas d'un trait bleu de deux pixels d'épaisseur :

<!-- Canevas dans la deuxième ligne -->
<Border BorderThickness="2" BorderBrush="Blue" Grid.Row="1" Grid.Column="0">
<Canvas Name="secondcanvas" Background="#FFDDDD">
<!-- On ajoute d'autres contrôles ici -->
</Canvas>
</Border>

C'est alors l'élément Border qui est positionné dans la grille. Il contient l'élément Canvas.

Un rappel des codes complets des fichiers avant de se lancer enfin avec VBA :

- le fichier sliver1.xaml :

<Canvas Name="rootcanvas" Background="#50FFFF00" xmlns="http://schemas.microsoft.com/client/2007">
<!-- La Grille -->
<Grid Name="rootgrid" ShowGridLines="False">
<!-- Définition des colonnes -->
<Grid.ColumnDefinitions>
<ColumnDefinition Width="*" />
</Grid.ColumnDefinitions>
<!-- Définition des lignes -->
<Grid.RowDefinitions>
<RowDefinition Height="Auto" />
<RowDefinition Height="*" />
</Grid.RowDefinitions>
<!-- Texte d'en-tête dans la première ligne -->
<TextBlock Grid.Row="0" Grid.Column="0" TextAlignment="Center">
Premier écran<LineBreak/>Silverlight
</TextBlock>
<!-- Canevas dans la deuxième ligne -->
<Border BorderThickness="2" BorderBrush="Blue" Grid.Row="1" Grid.Column="0">
<Canvas Name="secondcanvas" Background="#FFDDDD">
<!-- On ajoute d'autres contrôles ici -->
</Canvas>
</Border>
</Grid>
</Canvas>

- le fichier sliver1.html :

<HTML>
<script type="text/javascript">

function OnErrorEventHandler(sender, errorArgs)
{
// Create the error message to display.
var errorMsg = "Silverlight Error: \n\n";

// Specify error information common to all errors.
errorMsg += "Error Type:    " + errorArgs.errorType + "\n";
errorMsg += "Error Message: " + errorArgs.errorMessage + "\n";
errorMsg += "Error Code:    " + errorArgs.errorCode + "\n";

// Determine the type of error and add specific error information.
switch(errorArgs.errorType)
{
case "RuntimeError":
// Display properties specific to RuntimeErrorEventArgs.
if (errorArgs.lineNumber != 0)
{
errorMsg += "Line: " + errorArgs.lineNumber + "\n";
errorMsg += "Position: " +  errorArgs.charPosition + "\n";
}
errorMsg += "MethodName: " + errorArgs.methodName + "\n";
break;
case "ParserError":
// Display properties specific to ParserErrorEventArgs.
errorMsg += "Xaml File:      " + errorArgs.xamlFile      + "\n";
errorMsg += "Xml Element:    " + errorArgs.xmlElement    + "\n";
errorMsg += "Xml Attribute:  " + errorArgs.xmlAttribute  + "\n";
errorMsg += "Line:           " + errorArgs.lineNumber    + "\n";
errorMsg += "Position:       " + errorArgs.charPosition  + "\n";
break;
default:
break;
}
// Display the error message.
alert(errorMsg);
}

function OnResizeEventHandler(sender, args)
{
sender.width = sender.gethost().content.actualwidth;
sender.height = sender.gethost().content.actualheight;
sender.findname("rootgrid").width = sender.gethost().content.actualwidth;
sender.findname("rootgrid").height = sender.gethost().content.actualheight;
}

</script>
<body topmargin="0" leftmargin="0" rightmargin="0" bottommargin="0">
<object id="SilverLight1" data="data:application/x-silverlight," type="application/x-silverlight-2"
width="100%" height="100%">
<param name="source" value="silver1.xaml"/>
<param name="onerror" value="OnErrorEventHandler" />
<param name="onresize" value="OnResizeEventHandler" />
<!-- Display installation image. -->
<a href="http://go.microsoft.com/fwlink/?LinkID=149156&v=4.0.50303.0"
style="text-decoration: none;">
<img src="http://go.microsoft.com/fwlink/?LinkId=161376"
alt="Get Microsoft Silverlight"
style="border-style: none"/>
</a>
</object>
</body>
</HTML>

VII-F - Intégrer la page SilverLight dans un WebBrowser

Pour ajouter un Webbrowser à un formulaire, je vous renvoie vers le chapitre III-B Intégrer un navigateur internet à l'application.

Il suffit à l'ouverture du formulaire de naviguer vers notre page sliver1.html

Me.ctlNav.Navigate "C:\silver1.html"

Il faut préciser le chemin complet du fichier HTML.

Pour trouver le chemin de votre application, utilisez une de ces fonctions :

Application

Fonction

Access

CurrentProject.Path

Excel

ThisWorkbook.Path

Word

ThisDocument.Path

PowerPoint

ThisPresentation.Path

Pour Access, n'oubliez d'ajouter Object avant le navigate.

VII-G - Piloter la page SilverLight à partir de VBA

Nous allons dans ce chapitre utiliser VBA pour gérer l'objet Silverlight.

Silverlight n'étant pas du tout prévu pour VBA, cela ne va pas être si facile.

VII-G-1 - La librairie AgControl Type Library

Nous pourrions être tentés d'utiliser une librairie.
Il y en a bien une : AgControl Type Library.

Si on la référence, on voit ensuite dans l'explorateur d'objet (F2) les classes de cette librairie (nommée XcpControlLib) :

Il n'y a en fait pas grand-chose à notre disposition.

- IXcpControl est l'interface pour l'objet Plugin.
- IXcpObject est l'interface pour un élément contenu dans le Plugin.
- Xcpcontrol est un objet d'automation (j'avoue : je ne sais pas à quoi il sert).

Il est intéressant de voir les propriétés et méthodes disponibles, mais les éléments IXcpObject ne possèdent même pas de propriétés.
Nous n'allons en fait même pas utiliser cette librairie peu utile.
De plus, si nous référençons une version 4.0 de cette librairie par exemple, l'application ne fonctionnera pas sur un poste équipé seulement de la version 3 de Silverlight.
Nous utiliserons des objets non typés, et cela nous facilitera en fait la tâche.
Sinon, comment appeler une méthode d'un objet IXcpObject si rien n'est disponible : on aurait un message d'erreur alors que des méthodes existent pour ces éléments.

VII-G-2 - Atteindre le plugin Silverlight

On va chercher le plugin une fois la page chargée : dans l'événement DocumentComplete du navigateur.
Recherchez cet événement dans les listes déroulantes en haut du module de code du formulaire.

Private Sub ctlNav_DocumentComplete(ByVal pDisp As Object, URL As Variant)

End Sub

- pDisp est l'objet WebBrowser.
- URL est l'adresse du document HTML.

Le plugin est un élément HTML. Il est possible de le retrouver dans le document (HTMLDocument) avec fonction getElementById.
Nous avons vu cette fonction au chapitre IV.

L'objet plugin nous sera utile à plusieurs endroits du code.
Nous ajoutons donc une déclaration en en-tête du module du formulaire.

Private oSL As Object

Comme expliqué au chapitre précédent, oSL n'a pas de type particulier. Ce sera en fait un XcpControl.

Une fois le document chargé, on récupère l'objet plugin :

Private Sub ctlNav_DocumentComplete(ByVal pDisp As Object, URL As Variant)
Set oSL = pDisp.Document.getElementById("silverlight1").Object
End Sub

silverlight1 est l'id de notre objet dans le fichier silver1.html.
On rajoute Object à la fin car getElementById renvoie un élément HTML qui contient le plugin dans cette propriété Object.

On le voit bien dans la fenêtre Variables locales, avec un point d'arrêt dans l'événement DocumentComplete :

- pDisp est un WebBrowser.
- Document est un HTMLDocument.
- le sixième élément est un HTMLObjectElement, on le récupère avec getElementById.
- object est un IXcpControl2.

On retrouve sur cet objet la source ("silver1.xaml") et la gestion d'erreur ("OnErrorEventHandler").

On remarque une propriété importante : IsLoaded.
Cette propriété vaut True lorsque le plugin est chargé.

VII-G-3 - Lire la page Silverlight

On a donc récupéré un objet oSL.
Dans DocumentComplete, cet objet n'est pas encore chargé.

Si on place une boîte de message, on le voit bien :

Private Sub ctlNav_DocumentComplete(ByVal pDisp As Object, URL As Variant)
Set oSL = pDisp.Document.getElementById("silverlight1").Object
MsgBox oSL.IsLoaded
End Sub

La boîte de message indique "Faux"...
Si on veut lire le contenu du plugin, il faut d'abord attendre qu'il soit chargé :

Private Sub ctlNav_DocumentComplete(ByVal pDisp As Object, URL As Variant)
Set oSL = pDisp.Document.getElementById("silverlight1").Object
While Not oSL.IsLoaded
DoEvents ' indispensable pour ne pas tout bloquer
Wend
MsgBox oSL.IsLoaded
End Sub

La boîte de message indique "Vrai"... Le plugin est chargé.

Le contenu du plugin se trouve dans l'objet content dont vous trouverez les méthodes et propriétés ici : Silverlight Plug-in.

Les propriétés de cet objet ne sont pas directement accessibles en VBA.
Par exemple :

MsgBox oSL.Content.ActualWidth

Renvoie une erreur : Utilisation incorrecte de Null.
Pour lire une propriété, il faut utiliser l'instruction CallByName :

MsgBox CallByName(oSL.Content, "ActualWidth", VbGet)

La boîte de message affiche alors la largeur en pixels.

On souhaite maintenant récupérer l'élément racine, c'est-à-dire le canevas nommé "rootcanvas".

dim oRoot as object
set oRoot = CallByName(oSL.Content, "root", VbGet)

oRoot est alors un objet de type Canvas.

Pour rappel, les méthodes et propriétés des objets sont ici JavaScript API for Silverlight.

Pour afficher le nom de l'élément ("rootcanvas"), il suffit d'appeler sa propriété Name :

MsgBox CallByName(oRoot, "Name", VbGet)

Pour de nombreux objets, on a des méthodes GetValue et SetValue qui sont plus simples que CallByName :

MsgBox oRoot.getvalue("Name")

Si vous souhaitez connaître le type d'un objet, appelez la méthode toString :

MsgBox oRoot.toString

Pour la racine toString renvoie Canvas.
On peut aussi, en débogage, survoler l'objet oRoot. L'info-bulle nous indique la même information.

Maintenant pour obtenir les éléments contenus dans ce canevas, utilisez la propriété Children.
Chidren renvoie une collection.
On peut récupérer le nombre d'éléments avec Count.
GetItem permet alors de récupérer un élément par son indice (débute à 0).

Si vous utilisez une variable, il sera peut-être nécessaire de convertir l'indice en entier avec CInt.

Dim oRoot As Object
Dim oChildren As Object
Set oRoot = CallByName(oSL.Content, "root", VbGet)
Set oChildren = oRoot.getvalue("Children")
MsgBox "Nombre d'éléments dans le canevas racine : " & oChildren.getvalue("Count")
MsgBox "Nom du premier élément : " & oChildren.GetItem(0).getvalue("Name")

Il n'y a qu'un élément dans le canevas racine, c'est la grille "rootgrid".

On peut parcourir ainsi le contenu niveau par niveau.
Un exemple avec With :

' recherche la racine du plugin = canevas rootcanvas
With CallByName(oSL.Content, "root", VbGet)
' obtient la collection d'éléments du canevas
With .getvalue("children")
' Premier élément = rootgrid
With .GetItem(0)
' obtient la collection d'éléments de la grille
With .getvalue("children")
' Deuxième élément de la grille = border
With .GetItem(1)
' Element du border (il n'y en a qu'un)
With .getvalue("child")
' C'est le canevas secondcanvas
MsgBox .getvalue("name")
End With
End With
End With
End With
End With
End With

Si l'élément est nommé, on peut y accéder directement avec findName :

With oSL.Content.findName("secondcanvas")
MsgBox .getvalue("ActualWidth")
End With

findName peut également être utilisé sur un élément pour rechercher à l'intérieur de celui-ci.

VII-G-4 - Modifier la page Silverlight

Nous allons modifier le titre de la page.
Pour nous faciliter la tâche, nommons le TextBlock qui contient le titre dans le fichier silver1.xaml :

<!-- Texte d'en-tête dans la première ligne -->
<TextBlock Name="titre" Grid.Row="0" Grid.Column="0" TextAlignment="Center">
Premier écran<LineBreak/>Silverlight
</TextBlock>

On peut ainsi le retrouver facilement avec findName.

Dim oTitre As Object
Set oTitre = oSL.Content.findName("titre")

Pour modifier une propriété, c'est facile. Il suffit d'utiliser SetValue :

oTitre.SetValue "text", "Mon Nouveau Titre"
oTitre.SetValue "Foreground", "red"
oTitre.SetValue "FontSize", 24

Le texte du titre est alors modifié, en rouge, et de taille 24 pixels.

VII-G-5 - Ajouter dynamiquement un élément à la page Silverlight

Nous allons ici voir comment ajouter un élément à la page déjà chargée.
On continue avec les mêmes fichiers silver1.html et silver1.xaml.

Le fichier HTML est chargé dans un WebBrowser comme vu précédemment.
Et on attend dans DocumentComplete le chargement du plugin :

Private Sub ctlNav_DocumentComplete(ByVal pDisp As Object, URL As Variant)
Set oSL = pDisp.Document.getElementById("silverlight1").Object
While Not oSL.IsLoaded
DoEvents ' indispensable pour ne pas tout bloquer
Wend
' On écrira la suite du code ici
End Sub

On souhaite ajouter en VBA un texte au canevas "secondcanvas".
Commençons par écrire le code XAML de l'élément à ajouter.
On ajoute un simple TextBlock :

Dim sxaml As String
sxaml = "<TextBlock>Texte ajouté</TextBlock>"

Pour créer un élément, il faut utiliser la méthode CreateFromXaml de l'objet Content du plugin.
On aurait aimé pouvoir écrire :

set oElement = oSL.Content.CreateFromXAML(sxaml)

Mais ce code provoque une erreur.
La seule solution que j'ai trouvée est de faire la création de l'élément en JavaScript.
Voici une petite fonction à ajouter dans la balise script du fichier silver1.html.

function AddElement(sxaml,sobject,sname,position) {
// objet plugin
var plugin = document.getElementById(sobject);
// création du nouvel élément
var element = plugin.content.CreateFromXaml(sxaml);
// Ajout de l'élément
if (position==-1)
// Ajout à la fin
{    plugin.content.FindName(sname).children.add (element);    }
else
// Ajout avec position
{    plugin.content.FindName(sname).children.insert (position,element);    }

}

Cette fonction demande en paramètres :
- sxaml : le code XAML de l'élément à ajouter.
- sobject : le nom de l'objet Silverlight (Silverlight1 pour notre exemple).
- sname : le nom de l'objet dans lequel on ajoute l'élément.
- position : la position à laquelle ajouter l'élément. La position commence à l'indice 0, on utilise -1 pour ne pas indiquer de position.

La méthode add de la collection children ajoute un élément à la fin.
La méthode insert insère un élément à une position donnée.

Cette fonction peut être appelée en VBA ainsi :

pDisp.Document.parentWindow.execscript "AddElement('" & sxaml & "','SilverLight1','secondcanvas',-1)"

La méthode execscript de la fenêtre (parentWindow) du document permet d'exécuter du JavaScript.
La limitation est que tout doit être écrit dans une seule chaîne de caractères, y compris les paramètres.
C'est pour cela que les paramètres ne sont pas des objets (ce qui nous aurait simplifier la tâche).
Notez que execscript ne retourne pas de valeur.

Les chaînes de caractères sont encadrées par des simples quotes (').
Pour inclure ce caractère dans le XAML, utilisez "\'". Par exemple :

sxaml = "<TextBlock>J\'ajoute un texte</TextBlock>"

Les sauts de ligne (vbCrLf) provoquent également une erreur.
Il est souvent plus facile de créer d'abord l'élément puis de mettre à jour ses propriétés :

Dim sxaml As String
sxaml = "<TextBlock/>"
pDisp.Document.parentWindow.execscript "AddElement('" & sxaml & "','SilverLight1','secondcanvas',-1)"
With oSL.content.findname("secondcanvas").getvalue("Children").getitem(0)
.SetValue "text", "J'ajoute du texte" & vbCrLf & "avec un saut de ligne"
End With

De cette manière, pas de problème pour ajouter des quotes (') ou des sauts de ligne (vbCrLf).

Pour nous faciliter la tâche, on peut créer une fonction VBA :

'------------------------------------------------------------------------------
' Insère un élément dans silverlight
'------------------------------------------------------------------------------
' pxaml : code XAML : ex. : "<TextBlock>J\'ajoute un texte</TextBlock>"
' pDocument : un document HTML
' pObjet : l'Id de l'objet Silverlight dans le document HTML
' pElement : le nom de l'élément parent
' pPosition : position optionnelle de l'élément
'------------------------------------------------------------------------------
Public Function SLInsertElement(ByVal pxaml As String, pDocument As Object, pObject As String, _
pElement As String, Optional pPosition As Long = -1)
Dim sScript As String
sScript = "var plugin = document.getElementById('" & pObject & "');" & vbCrLf & _
"var element = plugin.content.CreateFromXaml('" & pxaml & "');" & vbCrLf
If pPosition = -1 Then
sScript = sScript & "plugin.content.FindName('" & pElement & "').children.add (element);"
Else
sScript = sScript & "plugin.content.FindName('" & pElement & "').children.insert  (element," & pPosition & ");"
End If
pDocument.parentWindow.execscript sScript
End Function

Cette fonction génère le code JavaScript nécessaire et l'exécute.
La fonction AddElement n'est plus utile dans le JavaScript du fichier silver1.html.

On pourra alors écrire :

SLInsertElement "<TextBlock>J\'ajoute un texte</TextBlock>", pDisp.Document, "SilverLight1", "secondcanvas"
SLInsertElement "<TextBlock Canvas.Top=""15"">Et un deuxième</TextBlock>", pDisp.Document, "SilverLight1", "secondcanvas"

On a ici ajouté deux textes.
Par défaut les éléments sont positionnés à l'origine du parent, en haut à gauche.
Pour les positionner, il faut utiliser les attributs Canvas.Top et Canvas.Left.
Bien ajouter Canvas, Top tout seul ne fonctionne pas.
Par contre, pour la taille, c'est Width et Height (sans le préfixe Canvas).

VII-H - Gérer les événements de la page SilverLight à partir de VBA

VII-H-1 - Saisie de texte

Commençons par ajouter à notre fichier xaml deux zones de saisie de texte :

<Canvas Name="rootcanvas" Background="#50FFFF00" xmlns="http://schemas.microsoft.com/client/2007">
<!-- La Grille -->
<Grid Name="rootgrid" ShowGridLines="False">
<!-- Définition des colonnes -->
<Grid.ColumnDefinitions>
<ColumnDefinition Width="*" />
</Grid.ColumnDefinitions>
<!-- Définition des lignes -->
<Grid.RowDefinitions>
<RowDefinition Height="Auto" />
<RowDefinition Height="*" />
</Grid.RowDefinitions>
<!-- Texte d'en-tête dans la première ligne -->
<TextBlock Name="titre" Grid.Row="0" Grid.Column="0" TextAlignment="Center">
Premier écran<LineBreak/>Silverlight
</TextBlock>
<!-- Canevas dans la deuxième ligne -->
<Border BorderThickness="2" BorderBrush="Blue" Grid.Row="1" Grid.Column="0">
<Canvas Name="secondcanvas" Background="#FFDDDD">
<TextBlock>Utilisateur :</TextBlock>
<TextBox Canvas.Left="120" Name="Login"/>
<TextBlock Canvas.Top="40">Mot de passe :</TextBlock>
<PasswordBox Canvas.Left="120" Canvas.Top="40" Name="Password"/>
</Canvas>
</Border>
</Grid>
</Canvas>

Le contrôle TextBox permet de saisir du texte.
Le contrôle PasswordBox permet de saisir du texte masqué (pour un mot de passe donc).

Par défaut les contrôles de saisie font (à peu près) 1 caractère de large et s'étendent durant la saisie.

Pour éviter ceci ,il suffit d'ajouter un attribut de taille (Width) aux éléments :

<TextBlock>Utilisateur :</TextBlock>
<TextBox Width="200" Canvas.Left="120" Name="Login"/>
<TextBlock Canvas.Top="40">Mot de passe :</TextBlock>
<PasswordBox Width="200" Canvas.Left="120" Canvas.Top="40" Name="Password"/>

Maintenant nous allons réagir à la saisie.
Pour capturer un événement d'un élément Silverlight, il faut créer un gestionnaire d'événements.
Nous avons déjà créé des gestionnaires d'événements aux chapitres IV-E et V-D-2.
C'est pour Silverlight la même procédure, il faut un objet ayant une méthode par défaut.
Créez un module de classe :

Option Explicit

Public Event SLEvent(sender As Variant, args As Variant)

Public Sub EventFromSL(sender As Variant, args As Variant)
'Attribute EventFromSL.VB_UserMemId = 0
RaiseEvent SLEvent(sender, args)
End Sub

Sauvegardez-le sous le nom clEventsSL.
Puis exportez ce module, supprimez-le et décommentez la ligne 'Attribute ... du fichier exporté avant de le réimporter.
EventFromSL est alors la méthode par défaut de cette classe.

Pour une utilisation dans une application Internet Explorer, il faut que ce module soit public.
Définissez la propriété Instancing du module à 2 - PublicNotCreatable.
Le module peut rester privé si la page est affichée dans un contrôle WebBrowser.

Pour utiliser cet objet, il faut d'abord le déclarer en en-tête de module avec WithEvents :

Private WithEvents oEventsTextChanged As clEventsSL

Puis instanciez l'objet à l'ouverture du formulaire par exemple :

Set oEventsTextChanged = New clEventsSL

Ce qui donne pour le code d'un userForm dans Excel :

Option Explicit

Private oSL As Object
Private WithEvents oEventsTextChanged As clEventsSL

Private Sub UserForm_Initialize()
Set oEventsTextChanged = New clEventsSL
Me.ctlNav.Navigate ThisWorkbook.Path & "/silver1.html"
End Sub

Private Sub ctlNav_DocumentComplete(ByVal pDisp As Object, URL As Variant)
Set oSL = pDisp.Document.getElementById("silverlight1").Object
While Not oSL.IsLoaded
DoEvents ' indispensable pour ne pas tout bloquer
Wend
End Sub

Maintenant il faut affecter ce gestionnaire d'événements aux éléments, sur le ou les événements désirés.
Cela se fait avec la méthode AddEventListener :

' TextBox : http://msdn.microsoft.com/en-us/library/cc917833(v=VS.95).aspx
oSL.content.findname("Login").addeventlistener "TextChanged", oEvents
' PasswordBox : http://msdn.microsoft.com/en-us/library/cc917814(v=VS.95).aspx
oSL.content.findname("Password").addeventlistener "PasswordChanged", oEvents

En commentaire dans le code, il y a les liens vers les pages MSDN où trouver les noms d'événements.
On a choisi, pour tester, les événements de changement de texte.

Créez enfin la procédure événementielle en choisissant dans les listes déroulantes en haut du module de code : oEventsTextChanged et SLEvent :

Private Sub oEventsTextChanged_SLEvent(sender As Variant, args As Variant)
Stop
End Sub

C'est cette procédure qui sera exécutée sur changement de texte dans un des contrôles.
On utilise le même objet pour les événements des deux contrôles, il faudra retrouver le contrôle initiateur de l'événement.

Comme il y a un point d'arrêt dans la procédure, si on modifie un texte l'exécution s'arrête.
On va en profiter pour étudier les paramètres sender et args.
sender est l'élément initiateur de l'événement.
sender.getvalue("name") nous permet de retrouver son nom.

Si on survole args on voit :
- TextChangedEventArgs pour l'utilisateur ;
- RoutedEventArgs pour le mot de passe.

Le type d'argument est donc fonction de l'événement.
Pour l'événement TextChanged du Login.
TextChangedEventArgs est défini ici : Membres TextChangedEventArgs.

Pour l'événement PasswordChange du Password :
RoutedEventArgs est défini ici : Membres RoutedEventArgs.

Je n'ai malheureusement pas réussi à extraire d'informations intéressantes de cet argument.
J'aurais aimé retrouver le nom de l'événement déclencheur (TextChanged ou PasswordChange).
Il faudra alors utiliser plusieurs objets de type clEventsSL pour gérer différents types d'événements.

Pour notre cas on va laisser tout dans la même procédure et vérifier le nom de l'objet sender.
Le texte est également lisible par VBA, en utilisant GetValue sur le sender pour lire ses propriétés.

Private Sub oEventsTextChanged_SLEvent(sender As Variant, args As Variant)
Select Case sender.getvalue("name")
Case "Login"
Debug.Print "Modification de Login :" & sender.getvalue("text")
Case "Password"
Debug.Print "Modification de Password :" & sender.getvalue("password")
End Select
End Sub

VII-H-2 - Gestion de la souris

Comme pour les événements de texte auparavant, il faut d'abord déclarer un objet en en-tête de module avec WithEvents :

Private WithEvents oEventsMouseDown As clEventsSL

Puis instancier cet objet à l'ouverture du formulaire par exemple :

Set oEventsMouseDown = New clEventsSL

Créez enfin la procédure événementielle en choisissant dans les listes déroulantes en haut du module de code : oEventsMouseDown et SLEvent :

Private Sub oEventsMouseDown_SLEvent(sender As Variant, args As Variant)
stop
End Sub

Pour déclencher l'événement il faut affecter l'objet à l'événement de l'élément voulu.
On va capturer les événements de click avec le bouton gauche de la souris sur le canevas racine.

oSL.content.findname("rootcanvas").addeventlistener "MouseLeftButtonDown", oEventsMouseDown

Ce code est à placer après la boucle d'attente de chargement du plugin.

Si on clique sur la page (sauf si on clique sur une zone de saisie), l'événement est déclenché.
Le code s'arrête sur l'instruction Stop, le temps de faire quelques investigations.

Survolez sender => il s'affiche son type : Canvas.
Pour voir son nom :

MsgBox sender.getvalue("name")

Quel que soit l'élément sur lequel vous cliquez, on affiche "rootcanvas" qui est le nom de l'élément auquel on a affecté le gestionnaire d'événement.
L'événement est donc transmis de l'élément sur lequel on clique à l'élément qui le contient.

Si vous survolez args (ou que vous affichez la valeur de args.toString), vous voyez : MouseButtonEventArgs.

Cet argument contient des informations intéressantes et exploitables :
- Source est l'élément déclencheur de l'événement (potentiellement différent de sender).
- GetPosition nous permet de trouver la position du clic (absolue ou relative).

MsgBox "Gérer par " & sender.tostring & " : " & sender.getvalue("name") & vbCrLf & _
"Envoyé par " & args.getvalue("Source").tostring & " : " & args.getvalue("Source").getvalue("name") & vbCrLf & _
"Position absolue " & args.GetPosition(Null).getvalue("x") & ":" & args.GetPosition(Null).getvalue("y") & vbCrLf & _
"Position relative " & args.GetPosition(args.getvalue("Source")).getvalue("x") & ":" & _
args.GetPosition(args.getvalue("Source")).getvalue("y")

Ce code nous affiche par exemple :

Gérer par Canvas : rootcanvas
Envoyé par Canvas : secondcanvas
Position absolue 380:229
Position relative 378:182

En remarque bien que sender est toujours le canevas racine, et que la valeur de "Source" est l'élément sur lequel on a cliqué.
Pour trouver la position, il faut préciser Null pour avoir la position absolue (c'est-à-dire l'origine en haut à gauche de la page).
Pour avoir la position à l'intérieur d'un élément, il faut préciser cet élément dans l'appel à GetPosition.
GetPosition renvoie une structure de type Point qui possède des propriétés X et Y.

Lien MSDN pour la gestion de la souris : Silverlight Mouse Support

Les fichiers xaml, HTML et un fichier Excel de test de ce chapitre sont disponibles sur ce lien.

VII-I - Dessiner avec la souris

Pour dessiner des traits, on peut utiliser l'objet InkPresenter.

Un trait est ajouté à la collection Strokes et possède des attributs de taille et couleur.

Voici un exemple à télécharger pour Excel : Tutoriel souris(miroir HTTP)

Lien MSDN pour l'objet InkPresenter : InkPresenter

Les fichiers xaml, HTML et un fichier Excel de test de ce chapitre sont disponibles sur ce lien.

Si vous n'avez pas Excel, voici l'extrait des codes :

fichier silvermouse.html

<HTML>
<script type="text/javascript">

function OnErrorEventHandler(sender, errorArgs)
{
// Create the error message to display.
var errorMsg = "Silverlight Error: \n\n";

// Specify error information common to all errors.
errorMsg += "Error Type:    " + errorArgs.errorType + "\n";
errorMsg += "Error Message: " + errorArgs.errorMessage + "\n";
errorMsg += "Error Code:    " + errorArgs.errorCode + "\n";

// Determine the type of error and add specific error information.
switch(errorArgs.errorType)
{
case "RuntimeError":
// Display properties specific to RuntimeErrorEventArgs.
if (errorArgs.lineNumber != 0)
{
errorMsg += "Line: " + errorArgs.lineNumber + "\n";
errorMsg += "Position: " +  errorArgs.charPosition + "\n";
}
errorMsg += "MethodName: " + errorArgs.methodName + "\n";
break;
case "ParserError":
// Display properties specific to ParserErrorEventArgs.
errorMsg += "Xaml File:      " + errorArgs.xamlFile      + "\n";
errorMsg += "Xml Element:    " + errorArgs.xmlElement    + "\n";
errorMsg += "Xml Attribute:  " + errorArgs.xmlAttribute  + "\n";
errorMsg += "Line:           " + errorArgs.lineNumber    + "\n";
errorMsg += "Position:       " + errorArgs.charPosition  + "\n";
break;
default:
break;
}
// Display the error message.
alert(errorMsg);
}

function OnResizeEventHandler(sender, args)
{
sender.width = sender.gethost().content.actualwidth;
sender.height = sender.gethost().content.actualheight;
sender.findname("rootgrid").width = sender.gethost().content.actualwidth;
sender.findname("rootgrid").height = sender.gethost().content.actualheight;
}

</script>
<body topmargin="0" leftmargin="0" rightmargin="0" bottommargin="0">
<object id="SilverLight1" data="data:application/x-silverlight," type="application/x-silverlight-2"
width="100%" height="100%">
<param name="source" value="silvermouse.xaml"/>
<param name="onerror" value="OnErrorEventHandler" />
<param name="onresize" value="OnResizeEventHandler" />
<!-- Display installation image. -->
<a href="http://go.microsoft.com/fwlink/?LinkID=149156&v=4.0.50303.0"
style="text-decoration: none;">
<img src="http://go.microsoft.com/fwlink/?LinkId=161376"
alt="Get Microsoft Silverlight"
style="border-style: none"/>
</a>
</object>
</body>
</HTML>

fichier silvermouse.xaml

<Canvas Name="rootcanvas" Background="#50FFFF00" xmlns="http://schemas.microsoft.com/client/2007">
<!-- La Grille -->
<Grid Name="rootgrid" ShowGridLines="False">
<!-- Définition des colonnes -->
<Grid.ColumnDefinitions>
<ColumnDefinition Width="*" />
</Grid.ColumnDefinitions>
<!-- Définition des lignes -->
<Grid.RowDefinitions>
<RowDefinition Height="Auto" />
<RowDefinition Height="*" />
</Grid.RowDefinitions>
<!-- Texte d'en-tête dans la première ligne -->
<TextBlock Name="titre" Grid.Row="0" Grid.Column="0" TextAlignment="Center">
Dessinez en cliquant sur le bouton gauche de la souris.
</TextBlock>
<!-- Canevas dans la deuxième ligne -->
<!-- <Border BorderThickness="2" BorderBrush="Blue" Grid.Row="1" Grid.Column="0">-->
<InkPresenter Grid.Row="1" Grid.Column="0" Background="#500000FF" Name="inkPresenterElement"/>
<!--</Border>-->
</Grid>
</Canvas>

code VBA du formulaire

Option Explicit

Private oSL As Object
Private WithEvents oInkPresenterMouseDown As clEventsSL
Private WithEvents oInkPresenterMouseMove As clEventsSL
Private WithEvents oInkPresenterMouseUp As clEventsSL
Private newStroke As Integer ' indice du trait en cours de dessin (doit être un entier Integer)
Private Const daWidth As Integer = 2
Private Const daHeight As Integer = 2
Private Const daColor As String = "Blue"
Private Const daOutlineColor As String = "Black"

Private Sub oInkPresenterMouseDown_SLEvent(sender As Variant, args As Variant)
sender.CaptureMouse
' Ajout du trait
SLAddStroke "<Stroke><Stroke.DrawingAttributes/></Stroke>", Me.ctlNav.Document, _
"SilverLight1", "inkPresenterElement"
' Indice = nombre de traits - 1
newStroke = sender.getvalue("strokes").getvalue("Count") - 1
' attributs
With sender.getvalue("strokes").getitem(CInt(newStroke)).getvalue("DrawingAttributes")
.Width = daWidth
.Height = daHeight
.Color = daColor
.OutlineColor = daOutlineColor
End With
' ajoute les points
sender.getvalue("strokes").getitem(CInt(newStroke)).getvalue("StylusPoints").AddStylusPoints _
args.GetStylusPoints(args.getvalue("Source"))
End Sub

Private Sub oInkPresenterMouseMove_SLEvent(sender As Variant, args As Variant)
On Error GoTo gestion_erreurs
If newStroke <> -1 Then
sender.getvalue("strokes").getitem(CInt(newStroke)).getvalue("StylusPoints").AddStylusPoints _
args.GetStylusPoints(args.getvalue("Source"))
End If
Exit Sub
gestion_erreurs:
' Erreur si dépasse le inkpresenter
End Sub

Private Sub oInkPresenterMouseUp_SLEvent(sender As Variant, args As Variant)
newStroke = -1
sender.ReleaseMouseCapture
End Sub

Private Sub UserForm_Initialize()
newStroke = -1
Set oInkPresenterMouseDown = New clEventsSL
Set oInkPresenterMouseMove = New clEventsSL
Set oInkPresenterMouseUp = New clEventsSL
Me.ctlNav.Navigate ThisWorkbook.Path & "/silvermouse.html"
End Sub

Private Sub ctlNav_DocumentComplete(ByVal pDisp As Object, URL As Variant)
Set oSL = pDisp.Document.getElementById("silverlight1").Object
While Not oSL.IsLoaded
DoEvents ' indispensable pour ne pas tout bloquer
Wend
oSL.content.findname("inkPresenterElement").addeventlistener "MouseLeftButtonDown", oInkPresenterMouseDown
oSL.content.findname("inkPresenterElement").addeventlistener "MouseMove", oInkPresenterMouseMove
oSL.content.findname("inkPresenterElement").addeventlistener "MouseLeftButtonUp", oInkPresenterMouseUp
End Sub

'------------------------------------------------------------------------------
' Insère un trait dans un InkPresenter dans silverlight
'------------------------------------------------------------------------------
' pxaml : code XAML
' pDocument&#160;: un document HTML
' pObjet&#160;: l'Id de l'objet Silverlight dans le document HTML
' pElement&#160;: le nom de l'élément parent
' pPosition&#160;: position optionnelle de l'élément
'------------------------------------------------------------------------------
Public Function SLAddStroke(ByVal pxaml As String, pDocument As Object, pObject As String, pElement As String)
Dim sScript As String
sScript = "var plugin = document.getElementById('" & pObject & "');" & vbCrLf & _
"var element = plugin.content.CreateFromXaml('" & pxaml & "');" & vbCrLf
sScript = sScript & "plugin.content.FindName('" & pElement & "').strokes.add (element);"
pDocument.parentWindow.execscript sScript
End Function

L'exemple ci-dessus utilise le module de classe clEventsSL vu précédemment.

Voici une image obtenue avec cet exemple :

VII-J - Capture d'écran

Il n'existe pas de méthode standard (sauf dans le code XAML managé compilé).

On peut juste envisager une capture d'écran via l'API Windows.

Je n'ai pas à ce jour de code à vous proposer...

VII-K - Images et Vidéos

Le plugin Silverlight accepte un nombre limité de formats de vidéos et d'images.

VII-K-1 - Images

Silverlight ne connaît que les formats d'image PNG et JPG.

Exemple d'intégration d'une image :

<Image Name="MyImage" Source="logoofficeweb.jpg" Width="150"/>

Les images peuvent aussi être utilisées pour remplir une forme :

<Ellipse Width="200" Height="100" Stroke="Black" StrokeThickness="1">
<Ellipse.Fill>
<ImageBrush ImageSource="logoofficeweb.jpg"/>
</Ellipse.Fill>
</Ellipse>

VII-K-2 - Vidéos

Vous trouverez sur MSDN la liste des formats de vidéo supportés : Supported Media Formats, Protocols, and Log Fields.

Pour insérer une vidéo, utilisez l'élément MediaElement :

<MediaElement Name="MyVideo" Source="myvideo.wmv" Width="150" Height="150"/>

Les vidéos peuvent aussi être utilisées pour remplir une forme :

<MediaElement Name="MyVideo" Source="myvideo.wmv" Opacity="0.0" IsMuted="True"/>
<Ellipse Width="150" Height="150">
<Ellipse.Fill>
<VideoBrush SourceName="MyVideo"/>
</Ellipse.Fill>
</Ellipse>

Il faut d'abord créer un MediaElement nommé et le rendre invisible (Opacity) et en sourdine (IsMuted).
Réutilisez ensuite le nom de cet élément dans l'élément VideoBrush.

Pour plus d'information sur l'élément VideoBrush :VideoBrush Overview.

VII-L - Transformations

Utilisez l'élément RenderTransform pour appliquer des transformations à un élément :

Exemple d'une image dont les transformations sont centrées sur l'origine (avec RenderTransformOrigin).
L'image est tournée de 30 ° et réduite en taille de moitié.

<Canvas xmlns="http://schemas.microsoft.com/client/2007">
<Image Name="MyImage" Source="logoofficeweb.jpg" Width="350" RenderTransformOrigin="0.5,0.5">
<Image.RenderTransform>
<TransformGroup>
<RotateTransform Name="MyRotate" Angle="30" />
<ScaleTransform Name="MyScale" ScaleX="0.5" ScaleY="0.5" />
</TransformGroup>
</Image.RenderTransform>
</Image>
</Canvas>

VII-M - Animations

Des animations peuvent être obtenues avec un élément Storyboard.

Sur le lien ci-dessus, vous avez un exemple d'animation d'opacité.

Voici le code XAML pour animer le même rectangle de gauche à droite :

<Canvas xmlns="http://schemas.microsoft.com/client/2007">
<Rectangle
Name="MyAnimatedRectangle"
Width="100"
Height="100"
Fill="Blue">
<Rectangle.Triggers>
<EventTrigger RoutedEvent="Rectangle.Loaded">
<BeginStoryboard>
<Storyboard>
<DoubleAnimation
Storyboard.TargetName="MyAnimatedRectangle"
Storyboard.TargetProperty="(Canvas.Left)"
From="0" To="400" Duration="0:0:2" AutoReverse="True" RepeatBehavior="Forever" />
</Storyboard>
</BeginStoryboard>
</EventTrigger>
</Rectangle.Triggers>
</Rectangle>
</Canvas>

Le tutoriel suivant, bien qu'écrit pour C#, contient des informations intéressantes pour les animations en XAML : Les animations avec Silverlight.

VII-N - Intégrer le code XAML dans la page HTML : Online XAML

Au lieu d'utiliser un fichier externe, il est possible d'intégrer le code XAML à la page HTML.

Voici un article de MSDN qui explique cette possibilité : Utilisation du XAML inline.

VII-O - Peut-on utiliser des barres de défilement ?

Non, l'objet ScrollView n'est disponible que pour une application compilée (API managée).
On peut agrandir le plugin (par exemple une taille à 200 %) et avoir alors des barres de défilement HTML sur tout le plugin, mais pas sur un élément particulier.

VII-P - Conclusion Silverlight

Si le code XAML non compilé est très restreint par rapport à ce que Silverlight peut offrir, on arrive tout de même à faire de beaux écrans.
L'intérêt de Silverlight dans Office reste à démontrer ; un écran d'accueil (SplashScreen) pourrait être du plus bel effet ;o).

VIII - API WinInet

Les API sont des fonctions que l'on trouve dans des librairies (fichiers .dll).
Ces fonctions ne sont pas directement utilisables par VBA, il n'y a pas de référence que l'on pourrait ajouter à l'éditeur VBA.

Il faut donc déclarer chacune de ces fonctions, en ciblant le bon fichier dll, et avec les paramètres requis.
Il faut également trouver les valeurs des constantes et déclarer les types.

C'est souvent un travail pénible, et on peut s'aider de sites tels que AllAPI.net

À partir d'Access 2010, une version 64 bits d'Office est disponible et demande une adaptation du code : Développer avec Office 64 bits

Avant de chercher la déclaration pour VB, la bible est MSDN : Windows Internet
MSDN est en anglais mais c'est ici que nous trouverons toute la documentation nécessaire.
Par contre, on n'y trouve rien pour VB...

En plus de fonctions communes, on trouve notamment dans WinInet un découpage en deux parties :
- les sessions HTTP.
- les sessions FTP.

Avant d'aller plus loin, voici quelques liens qui pourraient vous être utiles :
- Article Access : Repousser les limites d'Access - récupérer un fil RSS ;
- FAQ Excel : Comment récupérer le contenu d'un fichier txt placé sur internet ? ;
- Sources Access : Récupérer le code HTML d'une page Web à l'aide de l'APIWindows ;
- Sources Access : Récupérer le code HTML d'une page Web à l'aide de l'API Windows (2e méthode) ;
- Sources Access : Envoi/réception de fichier sur un serveur FTP.

Les codes trouvés dans ces pages sont exploitables quel que soit le produit Office utilisé.

VIII-A - Gestion d'erreurs WinInet

Lors de l'appel aux fonctions de l'API, les erreurs ne sont pas des erreurs VBA "classiques" que l'on peut gérer avec On Error.

Il faut vérifier le retour de chaque fonction (voir sur MSDN le retour en cas d'erreur), et en cas d'erreur utiliser Err.LastDllError pour connaître le numéro de l'erreur.
Les erreurs internet sont répertoriées ici : Error Messages.
Ou ici en français : INFO : Codes d'erreur WinInet (12001 à 12156).

VIII-B - Sessions HTTP

Cette partie est reprise dans la librairie Microsoft WinHTTP Services.
Si possible, il est beaucoup plus simple d'utiliser cette librairie que les API.

Pour une utilisation de l'API, nous allons avoir besoin de déclarer les fonctions, types, et constantes utilisés.
Ces déclarations doivent être écrites en en-tête de module.

Il faut d'abord trois fonctions pour se connecter à internet :

Private Declare Function InternetOpen Lib "wininet" Alias "InternetOpenA" (ByVal sAgent As String, _
ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, _
ByVal lFlags As Long) As Long
Private Declare Function InternetConnect Lib "wininet" Alias "InternetConnectA" (ByVal hInternetSession As Long, _
ByVal sServerName As String, ByVal nServerPort As Integer, ByVal sUserName As String, _
ByVal sPassword As String, ByVal lService As Long, ByVal lFlags As Long, _
ByVal lContext As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet" (ByRef hInet As Long) As Long

Et voici les constantes dont nous avons besoin :

Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_SERVICE_HTTP = 3
Private Const INTERNET_INVALID_PORT_NUMBER = 0

Pour trouver la valeur d'une constante, recherchez dans Google le nom de la constante suivi de Declare.
On trouve alors la plupart du temps la valeur recherchée.

Dans une nouvelle procédure ConnectHTTP, nous allons nous connecter au site www.developpez.com.

Première étape, on se connecte à internet grâce à InternetOpen :

Dim hOpen As Long
hOpen = InternetOpen("SiteHTTP", INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)

- Le premier paramètre est un nom libre.
- Le deuxième paramètre définit l'utilisation d'un proxy : INTERNET_OPEN_TYPE_PRECONFIG demande de rechercher le proxy configuré par défaut dans Windows.
- Les troisième et quatrième paramètres définissent des paramètres de proxy que nous n'utilisons pas ici.
- vbNullString est une chaîne de caractères spéciale qui indique qu'aucune valeur n'est passée en paramètre.
- Le cinquième et dernier paramètre est un flag (booléen) qui pourrait définir une exécution asynchrone ou la gestion du cache ; on ne l'utilise pas ici.

La fonction renvoie un identifiant (appelée handle) que nous devons conserver pour la suite.
Si la connexion est effectuée sans erreur, ce handle est différent de zéro.

Deuxième étape : la connexion au site web grâce à la fonction InternetConnect :

Sub ConnectHTTP()
Dim hOpen As Long, hConnect As Long
hOpen = InternetOpen("SiteHTTP", INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
If hOpen <> 0 Then
hConnect = InternetConnect(hOpen, "www.developpez.com", _
INTERNET_INVALID_PORT_NUMBER, vbNullString, vbNullString, INTERNET_SERVICE_HTTP, 0, 0)
End If
End Sub

- On réutilise en premier paramètre l'identifiant retourné par InternetOpen.
- Ensuite on indique l'adresse du site auquel on souhaite se connecter.
- En troisième paramètre on définit le port de connexion : utilisez INTERNET_INVALID_PORT_NUMBER pour le port par défaut en fonction du service défini ensuite.
- Un utilisateur et un mot de passe peuvent être définis si besoin dans les deux paramètres suivants.
- le sixième paramètre spécifie le service utilisé pour la connexion : HTTP ici, on pourrait indiquer FTP par exemple.
- les deux derniers paramètres sont inutilisés pour notre besoin.

La fonction renvoie également un identifiant (handle) que nous devons conserver pour la suite.
Si la connexion au site est effectuée sans erreur, ce handle est différent de zéro.

Il faut, à la fin, penser à fermer les connexions ouvertes avec InternetCloseHandle :

Sub ConnectHTTP()
Dim hOpen As Long, hConnect As Long
hOpen = InternetOpen("SiteHTTP", INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
If hOpen <> 0 Then
hConnect = InternetConnect(hOpen, "www.developpez.com", _
INTERNET_INVALID_PORT_NUMBER, vbNullString, vbNullString, INTERNET_SERVICE_HTTP, 0, 0)
If hConnect <> 0 Then
InternetCloseHandle hConnect
End If
InternetCloseHandle hOpen
End If
End Sub

Une fois la connexion établie, nous pouvons envoyer des requêtes à la page comme nous l'avions fait avec la librairie WinHTTP.
C'est toutefois bien plus complexe à coder avec les API.

Je vous invite, pour cette partie, à consulter cette source : Récupérer le code HTML d'une page Web à l'aide de l'API Windows (2e méthode).

Une autre source également intéressante, qui utilise InternetOpenUrl au lieu de InternetConnect :
Récupérer le code HTML d'une page Web à l'aide de l'APIWindows.

VIII-C - Sessions FTP

Pour cette partie, il n'y a pas de librairie disponible.
Seules les API nous permettent d'utiliser la partie FTP de WinInet.

VIII-C-1 - Sessions FTP sans proxy

Un exemple est disponible dans les sources :
- Sources Access : Envoi/réception de fichier sur un serveur FTP.

L'utilisation est similaire à une session HTTP, à l'aide des fonctions : InternetOpen, InternetConnect et InternetCloseHandle.
La différence est la spécification du service FTP à l'appel de InternetConnect.
Il faut, à la place de INTERNET_SERVICE_HTTP, utiliser INTERNET_SERVICE_FTP qui se déclare ainsi :

Private Const INTERNET_SERVICE_FTP = 1

Dans l'exemple, la valeur 1 est utilisée directement.

Une fois la connexion établie, on peut utiliser les fonctions WinInet dont le nom commence par FTP.

VIII-C-2 - Sessions FTP avec proxy

Vous rencontrez des problèmes de connexion si vous êtes derrière un proxy HTTP (de type CERN).

Ces deux articles de MSDN expliquent le principe d'un tel proxy et comment contourner le problème :
- Comment faire du FTP un proxy CERN en utilisant l'API WinInet ;
- Exemple : FTP proxy CERN protégé par mot de passe en utilisant l'API WinInet.

La solution est d'utiliser la fonction InternetOpenUrl.
Le mot de passe pour le FTP sera précisé dans l'adresse.

Voici un exemple :

Option Explicit

Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0

Private Declare Function InternetOpen Lib "wininet" Alias "InternetOpenA" _
(ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, _
ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function InternetConnect Lib "wininet" Alias "InternetConnectA" _
(ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, _
ByVal sUserName As String, ByVal sPassword As String, ByVal lService As Long, _
ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet" (ByRef hInet As Long) As Long
Private Declare Function InternetOpenUrl Lib "wininet" Alias "InternetOpenUrlA" _
(ByVal hInternetSession As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, _
ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function InternetReadFile Lib "wininet" (ByVal hFile As Long, sBuffer As Any, _
ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer

Function DownloadFTP()
Dim hOpen As Long
Dim hInternetFile As Long
Dim buffer() As Byte
Dim lRead As Long
Dim f As Integer
' Connexion internet
hOpen = InternetOpen("SiteWeb", INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
' Ouverture du fichier par son URL complète
hInternetFile = InternetOpenUrl(hOpen, "ftp://login:pass@monftp.com/monfichier.gif", vbNullString, 0, 0, 0)
' Création du fichier cible sur le PC
f = FreeFile
Open ThisWorkbook.Path & "\monfichier.gif" For Binary As #f
' Lecture du fichier par paquet de 1024 bytes
Do
' Dimensionne le buffer pour accueillir 1024 bytes
ReDim buffer(1 To 1024)
' Lecture de 1024 bytes du fichier
If InternetReadFile(hInternetFile, buffer(1), 1024, lRead) Then
If lRead > 0 Then
' Redimensionne le buffer à la taille réellement lue
' Utilise Preserve pour ne pas effacer le contenu
ReDim Preserve buffer(1 To lRead)
' Ecrit le buffer dans le fichier
Put #f, , buffer()
Else
' Plus de données à lire => on sort de la boucle
Exit Do
End If
Else
' Erreur de lecture => on sort de la boucle
' Gestion d'erreurs à compléter ici
Exit Do
End If
Loop
' Fermeture du fichier
Close #f
' Fermeture de tous les handles
InternetCloseHandle hInternetFile
InternetCloseHandle hOpen
End Function

On passe donc par HTTP pour télécharger un fichier sur un FTP.

Par contre on ne peut pas faire l'inverse, c'est-à-dire envoyer un fichier sur le serveur.
On verra dans le chapitre Winsock suivant comment envoyer un fichier par FTP en passant par un proxy.

IX - API URL Monikers (URLDownloadToFile)

Comme WinInet et Winsock, URL Monikers est une librairie dont nous devons déclarer les fonctions, types et constantes utilisées.

La liste des fonctions de cette API est sur MSDN en anglais : URL Monikers Functions.

Nous allons utiliser une seule fonction de cette API : URLDownloadToFile.
Elle est disponible à partir d'Internet Explorer 3.0 et Windows NT4.0, donc sur pratiquement tous les PC.

Très pratique, cette API va nous permettre de télécharger un fichier en une instruction.

Il faut d'abord déclarer la fonction en en-tête de module :

Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Ensuite l'appel de cette fonction est très simple :

Function DownloadUrlMon()
' Téléchargement depuis FTP avec mot de passe
URLDownloadToFile 0, "ftp://login:pass@monftp.com/monfichier.gif", ThisWorkbook.Path & "\monfichier.gif", 0, 0
' Téléchargement depuis HTTP
URLDownloadToFile 0, "http://monsite.com/monfichier.gif", ThisWorkbook.Path & "\monfichier.gif", 0, 0
End Function

Je ne l'ai pas vu dans la documentation, mais la fonction utilise apparemment la configuration Windows par défaut du proxy.

Vous avez peut-être vu le dernier paramètre lpfnCB qui devrait permettre de récupérer des événements, notamment de progression du téléchargement.
Sa mise en œuvre est très complexe en VB.
Si vous souhaitez connaître la progression du téléchargement, je vous invite à utiliser WinInet comme vu dans le chapitre précédent.

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.

déclaration de socket dans modWinsock

Public Declare Function socket Lib "ws2_32.dll" (ByVal AddressFamily As Long, ByVal SocketType As Long, ByVal Protocol As Long) As Long
Public Declare Function closesocket Lib "ws2_32.dll" (ByVal hSocket As Long) As Long

Public Const AF_INET = 2
Public Const SOCK_STREAM = 1

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

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

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

Utilisons ces fonctions pour créer une socket :

création de socket

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

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

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

X-D - Connecter une socket

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

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

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

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

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

déclaration de Connect dans modWinsock

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

déclaration de htons

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 :

déclarations pour sin_addr à ajouter au module modWinsock

Public Declare Function gethostbyname Lib "ws2_32.dll" (ByVal Name As String) As Long
Public Declare Function inet_addr Lib "ws2_32.dll" (ByVal IpAddress As String) As Long
Public Declare Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, Source As Any, ByVal length As Long)

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

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

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

fonction addrfromhost à ajouter au module modWinsock

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

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

[...]
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.

déclaration de recv dans modWinsock

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

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

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

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

réception de données

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

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

Voici le résultat obtenu :

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

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

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

X-I - Envoyer des données

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

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

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

déclaration de send dans modWinsock

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

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

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

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

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

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

Envoi de commande EHLO

[...]
' 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 :

déclaration de select dans modWinsock

Public Declare Function wselect Lib "ws2_32.dll" Alias "select" (ByVal Reserved As Long, _
ByRef ReadFds As FD_SET, ByRef WriteFds As FD_SET, _
ByRef ExceptFds As FD_SET, ByRef timeout As TIMEVAL) As Long

Public Type FD_SET
fd_count     As Long
fd_array(1 To 64) As Long
End Type

Public Type TIMEVAL
tv_sec  As Long
tv_usec As Long
End Type

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

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

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

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

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

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

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

fonctions d'envoi et réception dans modWinsock

' -----------------------------------------------------------------------------
' 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&#160;: " & vbCrLf & lStrToSend
' Réception des données
lStrToReceive = RecvStrTO(lsock)
Debug.Print "Octets reçus&#160;: " & Len(lStrToReceive) & vbCrLf & lStrToReceive
End If
Else
Debug.Print "Erreur de connexion 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 :

Envoi de mail avec free

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

déclaration des fonctions de crypt32.dll dans modWinsock

Public Declare Function CryptBinaryToString Lib "crypt32.dll" Alias "CryptBinaryToStringA" _
(ByVal pbBinary As String, ByVal cbBinary As Long, ByVal dwFlags As Long, _
ByVal pszString As String, ByRef pcchString As Long) As Long

Public Const CRYPT_STRING_BASE64 = 1

fonctions de codage dans modWinsock

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

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

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

Voici un exemple d'envoi de mail avec Hotmail :

Envoi de mail avec hotmail

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

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

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

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

Voici un exemple d'envoi de fichier texte joint :

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

X-L - Gestion d'un serveur FTP

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

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

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

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

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

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

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

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

Voici cette fonction RecvStrTOFTP :

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

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

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

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.

déclaration des fonctions serveur dans modWinsock

Public Declare Function bind Lib "ws2_32.dll" (ByVal hSocket As Long, ByRef Name As SOCKADDR, ByVal NameLen As Long) As Long
Public Declare Function listen Lib "ws2_32.dll" (ByVal hSocket As Long, ByVal BackLog As Long) As Long
Public Declare Function accept Lib "ws2_32.dll" (ByVal hSocket As Long, ByRef SocketAddress As SOCKADDR, _
ByRef AddrLen As Long) As Long

Autres fonctions utiles dans modWinsock

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

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

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

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

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

Module serveur pour Excel

Option Explicit

Dim ServerSock As Long ' Socket serveur
Dim ClientSocks As FD_SET ' Sockets client

' Vérifie si un client a envoyé des données
Public Function ServerCheckRecv()
Dim fdr As FD_SET, fdw As FD_SET, fde As FD_SET
Dim ti As TIMEVAL
Dim lname As SOCKADDR
Dim sStrToRecv As String
Dim cpt As Long
' Timeout à zéro seconde
ti.tv_sec = 0
' Fait une copie de la structure contenant les clients (fdr est modifiée par wselect)
LSet fdr = ClientSocks
If wselect(0, fdr, fdw, fde, ti) > 0 Then
' Pour chaque client ayant envoyé des données
For cpt = 1 To fdr.fd_count
' Lit les données
sStrToRecv = RecvStrTO(fdr.fd_array(cpt), 0)
' Ecrit les données reçues dans la fenêtre Exécution
If sStrToRecv <> "" Then Debug.Print sStrToRecv
Next
End If
' Relance cette procédure dans une seconde
If ServerSock <> 0 Then Application.OnTime DateAdd("s", 1, Now), "ServerCheckRecv"
End Function

' Vérifie si une connexion est en attente et l'accepte
Public Function ServerCheckAccept()
Dim fdr As FD_SET, fdw As FD_SET, fde As FD_SET
Dim ti As TIMEVAL
Dim lname As SOCKADDR
Dim lConnexionSocket As Long
Dim saddr As String, saddrlen As Long
' Timeout à zéro seconde
ti.tv_sec = 0
fdr.fd_count = 1
' Vérifie la socket serveur pour les connexions en attente
fdr.fd_array(1) = ServerSock
' Si une connexion est en attente
If wselect(0, fdr, fdw, fde, ti) > 0 Then
' Accepte la connexion
' lConnexionSocket est la socket connectée
lConnexionSocket = accept(ServerSock, lname, LenB(lname))
' Ajoute la socket client à la structure ClientSocks
ClientSocks.fd_count = ClientSocks.fd_count + 1
ClientSocks.fd_array(ClientSocks.fd_count) = lConnexionSocket
' Récupère l'adresse de la socket client
saddrlen = 256
saddr = Space(saddrlen)
WSAAddressToString lname, LenB(lname), 0, saddr, saddrlen
saddr = Left(saddr, saddrlen - 1)
' Envoie au client un message de connexion
SendStrTO lConnexionSocket, saddr & " Connected OK"
End If
' Relance cette procédure dans une seconde
If ServerSock <> 0 Then Application.OnTime DateAdd("s", 1, Now), "ServerCheckAccept"
End Function

' Lance le serveur
Function RunServeur()
Dim lData As WSADATA
Dim lname As SOCKADDR
' Initialisation de Winsock
If WSAStartup(257, lData) = 0 Then
' Création d'une socket serveur
ServerSock = socket(AF_INET, SOCK_STREAM, 0)
If ServerSock <> -1 Then
lname.sin_family = AF_INET ' famille "classique"
lname.sin_port(1) = 1025 \ 256 ' première partie du port
lname.sin_port(2) = 1025 Mod 256 ' deuxième partie du port
lname.sin_addr = inet_addr("127.0.0.1") ' adresse de la boucle local
' Lie la socket
If bind(ServerSock, lname, LenB(lname)) = 0 Then
' Place la socket en écoute
' 20 est le nombre maximal de clients en attente de connexion
If listen(ServerSock, 20) = 0 Then
' Exécute les fonctions d'acceptation et de réception dans une seconde
Application.OnTime DateAdd("s", 1, Now), "ServerCheckAccept"
Application.OnTime DateAdd("s", 1, Now), "ServerCheckRecv"
End If
End If
End If
End If
End Function

' Arrête le serveur
Function StopServeur()
Dim cpt As Long
' Ferme toutes les connexions
For cpt = 1 To ClientSocks.fd_count
closesocket ClientSocks.fd_array(cpt)
Next
ClientSocks.fd_count = 0
' Ferme la socket serveur
closesocket ServerSock
ServerSock = 0
' Purge Winsock
WSACleanup
End Function

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

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

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

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

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

Module Client

Option Explicit

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

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

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

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

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

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

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

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

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

X-N - Module modWinsock

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

Module modWinsock

'***************************************************************************************
'* Procédures pour winsock
'***************************************************************************************
Option Explicit

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

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

Public Type TIMEVAL
tv_sec  As Long
tv_usec As Long
End Type

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

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

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

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

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

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

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

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

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

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

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

If Not pCallBackObject Is Nothing Then
lLog = Format(lSent / lTotal, "0%")
If Len(lLog) < 4 Then lLog = Space$(4 - Len(lLog)) & lLog
CallByName pCallBackObject, "FTPTransfertCallBack", VbMethod, lLog, lCancel
If lCancel Then
'GetFile = GetFile & SendCommand("ABOR")
SendBinTO = False
Exit Do
End If

End If

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

X-O - Compatibilité avec Office 64 bits

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

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

X-P - Connexion SSL sécurisée

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

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

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

X-Q - Conclusion Winsock

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

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

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

XI - Autre possibilité d'envoi de mails

Nous avons vu dans le chapitre Winsock la possibilité d'envoyer un mail qui requiert un code VBA assez complexe.

Il y a bien d'autres méthodes possibles : avec Outlook, Lotus Notes, ou CDO par exemple.
Pensez à rechercher dans les FAQ ou les Sources.
On trouve également de nombreux messages traitant de l'envoi de mail sur les forums Office.

Voici par exemple un code d'envoi de mail avec CDO et une boîte Hotmail :

Function sendcdo()
Dim oCDO As Object
Set oCDO = CreateObject("CDO.Message")
With oCDO
With .Configuration.Fields ' Configuration du compte mail SMTP pour hotmail
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.live.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = "587"
'----- Dans le cas ou le serveur demande une authentification
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "mon.mail@hotmail.fr"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "monmotdepasse"
'----------------
.Update
End With
.From = "mon.mail@hotmail.fr"
.To = "mail.destinataire@hotmail.fr"
.Subject = "Essai de mail " & Now
.TextBody = "Voici un petit message " & vbCrLf & "pour tester l'envoi de mail par CDO"
.send
End With
End Function

Ce code est issu du forum VBScript.

XII - Autres plugins pour navigateur internet

Nous n'avons abordé dans cet article que le plugin SilverLight.

Il est bien entendu possible d'intégrer à une page internet n'importe quel plugin : SVG, JAVA...
Par contre je n'ai pas étudié la possibilité d'un dialogue entre VBA et ces plugins.

J'ai privilégié Silverlight car il permet de créer des pages simples avec du code texte sans besoin d'un environnement pour le compiler.

XIII - Conclusion

Le sujet étant vaste, ce tour d'horizon du développement Web est sans fin.
Il y a toujours beaucoup de choses à découvrir.

Un avis personnel pour finir : je trouve dommage que le VBA soit souvent oublié dans le développement et la documentation.
On doit parfois user d'astuces et s'arracher quelques cheveux pour parvenir à nos fins, quand on y arrive...

XIV - Remerciements

Merci à :
- ClaudeLELOUP pour la relecture de cet article ;
- djibril pour le temps passé à améliorer les outils de rédaction ;
- tous les autres qui m'ont aidé à améliorer cet article.