Option Explicit
'============== Points à vérifier ====================================
'Cocher les références suivantes :
' Microsoft Internet Controls
' Microsoft HTML Object Library
' Microsoft ActiveX Data Objects 2.8 Library (v 2.8 au minimum)
' Microsoft XML, vx.x
' Windows Script Host Object Model
'ou déclarer tous les objets
' Dim oNomObjet as Object
' Set oNomObjet = CreateObject("Nom_de_l'objet")
'et remplacer le nom des types d'énumération par leur valeur numérique
'======================================================================
Const strURL As String = "http://data.hgca.com/archive/future.asp" 'URL du site
Const strFolderName As String = "téléchargement" 'nom du dossier
'Procédures adaptées de http://arkham46.developpez.com/articles/office/officeweb/
'et de http://qwazerty.developpez.com/tutoriels/vba/ie-et-vba-excel/
Sub XmlHttpRequest_IE()
Dim oXmlHttp As XmlHttp
Dim oStream As ADODB.Stream
Dim oNav As SHDocVw.InternetExplorer
Dim oDoc As DispHTMLElementCollection
Dim oColLinks As IHTMLElementCollection
Dim oLink As HTMLAnchorElement
Dim strPathName As String
Dim strFileName As String
strPathName = GetDesktopFolder & "\" & strFolderName & "\"
Set oNav = New SHDocVw.InternetExplorer 'on accède à Internet Explorer
'oNav.Visible = True 'uniquement si l'on veut afficher la page
oNav.navigate strURL
' Attente avec timeout de 10 s
If WaitIE(oNav, 10) Then
' 10 s écoulées et page non chargée
MsgBox "Temps écoulé !"
Else
' Page chargée, on continue
On Error Resume Next
MkDir strPathName 'si le dossier n'existe pas on le crée
On Error GoTo 0 'On réactive la gestion d'erreur au cas une une erreur a été levée
'on lance une requête
Set oXmlHttp = New XmlHttp
Set oStream = New ADODB.Stream
oXmlHttp.Open "GET", strURL, False
oXmlHttp.send
oStream.Open 'on ouvre l'objet stream
Set oDoc = oNav.document 'on accède à la structure HTML du document
Set oColLinks = oDoc.Links 'on accède à la collection des liens
For Each oLink In oColLinks 'on accède à chaque lien
If oLink.innerHTML = "Excel" Then
strFileName = Replace(oLink.nameProp, "%20", " ") 'remplacement du %20 retrouvé dans l'URL par l'espace
oStream.Type = adTypeBinary ' 1 = no adTypeBinary, 2 = adTypeText
oStream.write oXmlHttp.responseBody
oStream.SaveToFile strPathName & strFileName, adSaveCreateOverWrite ' 1 = no overwrite, 2 = overwrite
End If
Next oLink
oStream.Close 'on ferme l'objet stream
End If
oNav.Quit 'ferme IE
Set oXmlHttp = Nothing
Set oStream = Nothing
Set oNav = Nothing
Set oDoc = Nothing
Set oColLinks = Nothing
Set oLink = Nothing
MsgBox "Traitement terminé !"
End Sub
' Attend que la page internet soit chargée
' pTimeOut est un time out en secondes (WaitIE vaut True si Timeout)
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 'READYSTATE_COMPLETE = 4
If pTimeOut > 0 And Timer - lTimer > pTimeOut Then
WaitIE = True
Exit Do
End If
Loop
End Function
'Récupère le chemin du bureau
Function GetDesktopFolder()
Dim oShell As WshShell
Set oShell = New WshShell
GetDesktopFolder = oShell.SpecialFolders("Desktop")
End Function
