Ouverture lien http vers fichier dans Excel , supprimer le message d'alerte Office

david84 à dit:

Re
Effectivement je n'avais pas remarqué ce problème de compatibilité...pas le temps tout de suite de voir pourquoi mais supprime le dossier téléchargement existant et lance cette procédure (c'est plus lent mais sur mon ordinateur je n'ai pas de problème de compatibilité) :

Code:

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 oNav As SHDocVw.InternetExplorer
Dim oDoc As DispHTMLElementCollection
Dim oColLinks As IHTMLElementCollection
Dim oLink As HTMLAnchorElement
Dim strPathName 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
  
  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
       Call DownloadFile(oLink.Href, strPathName, oLink.nameProp)
    End If
  Next oLink

End If

oNav.Quit 'ferme IE

Set oNav = Nothing
Set oDoc = Nothing
Set oColLinks = Nothing
Set oLink = Nothing

MsgBox "Traitement terminé !"
End Sub

Sub DownloadFile(strFileURL As String, strPathName As String, strFileName As String)
Dim oStream As ADODB.Stream
Dim oXmlHttp As XmlHttp

strFileName = Replace(strFileName, "%20", " ") 'remplacement du %20 retrouvé dans l'URL par l'espace

Set oXmlHttp = New XmlHttp
oXmlHttp.Open "GET", strFileURL, False, vbNullString, vbNullString
oXmlHttp.send

strFileURL = oXmlHttp.responseBody
If oXmlHttp.Status = 200 Then
  Set oStream = New ADODB.Stream
  oStream.Open
  oStream.Type = adTypeBinary ' 1 = no adTypeBinary, 2 = adTypeText
  oStream.write oXmlHttp.responseBody
  oStream.SaveToFile strPathName & strFileName, adSaveCreateOverWrite ' 1 = no overwrite, 2 = overwrite
  oStream.Close
End If
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

Qu'est ce que cela donne chez toi ?
A+

Cliquez pour agrandir...

J'ai copié ton texte dans un module vierge sans regarder ..

Cliquez pour agrandir...

david84 à dit:

Mais il faut regarder de ton côté quand même...sous quelle version d'Excel tu es ? Chez moi pas de problème.
Cf. PJ
A+

Cliquez pour agrandir...

J'ai activé toutes les bibliothèques indiquées dans ton programme, sauf Internet Controls

Cliquez pour agrandir...

david84 à dit:

Re

Essaie le code ci-dessus :

Code:

Option Explicit

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 oNav As Object
Dim oDoc As Object
Dim oColLinks As Object
Dim oLink As Object
Dim strPathName As String

strPathName = GetDesktopFolder & "\" & strFolderName & "\"

Set oNav = CreateObject("InternetExplorer.application") '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
  
  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
    Call DownloadFile(oLink.Href, strPathName, oLink.nameProp)
    End If
  Next oLink
End If

oNav.Quit 'ferme IE

Set oNav = Nothing
Set oDoc = Nothing
Set oColLinks = Nothing
Set oLink = Nothing

MsgBox "Traitement terminé !"
End Sub

Sub DownloadFile(strFileURL As String, strPathName As String, strFileName As String)
Dim oStream As Object
Dim oXmlHttp As Object

strFileName = Replace(strFileName, "%20", " ") 'remplacement du %20 retrouvé dans l'URL par l'espace

Set oXmlHttp = CreateObject("Microsoft.XMLHTTP")
oXmlHttp.Open "GET", strFileURL, False, vbNullString, vbNullString
oXmlHttp.send

strFileURL = oXmlHttp.responseBody
If oXmlHttp.Status = 200 Then
  Set oStream = CreateObject("ADODB.Stream")
  oStream.Open
  oStream.Type = 1 ' 1 = no adTypeBinary, 2 = adTypeText
  oStream.write oXmlHttp.responseBody
  oStream.SaveToFile strPathName & strFileName, 2 ' 1 = no overwrite, 2 = overwrite
  oStream.Close
End If
Set oXmlHttp = Nothing
Set oStream = Nothing
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 Object, Optional pTimeOut As Long = 0) As Boolean
Dim lTimer As Double
lTimer = Timer
Do
  DoEvents
  If oIE.ReadyState = 4 And Not oIE.Busy Then Exit Do
  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 Object
  Set oShell = CreateObject("WScript.Shell")
  GetDesktopFolder = oShell.SpecialFolders("Desktop")
End Function

Est-ce mieux ? Sinon il te faudra charger la dll manquante
A+

Cliquez pour agrandir...

Cette dernière macro plante EXCEL.

Cliquez pour agrandir...

david84 à dit:

A quelle ligne ?
Si d'autres personnes pouvaient tester la macro du message #22 pour me dire si cela plante chez eux et si oui à quel endroit.
A+

Cliquez pour agrandir...

Staple1600 à dit:

Bonsoir à tous


Le code du message a été testé avec succès sur ce PC.
Ce PC étant sous XP et avec Excel 2003.

Les fichiers sont téléchargés et s'ouvrent sans souci dans Excel.

Je ne sais pas si cela fera avancer le schmilblik , vu que c'est sur XL 2007 que cela coince
(enfin plutôt sur cet Excel 2007)

Cliquez pour agrandir...

david84 à dit:

Bonjour,

En pilotant et en ouvrant Internet Explorer la procédure du message #22 fonctionne.

Restait la procédure sans ouvrir Internet Explorer où les fichiers téléchargés n'étaient pas exploitables.

Je crois avoir compris comment solutionner le problème : il faut apparemment utiliser 2 requêtes XmlHttp différentes :
- la première va permettre de récupérer la structure du document HTML du site et donc d'accéder à la collection des liens pointant vers les fichiers ;
- la seconde va traiter individuellement chaque lien afin de télécharger le fichier vers le dossier "téléchargement" créé sur le bureau.

Code:

Option Explicit
'Cette procédure permet de télécharger des fichiers en masse sans nécessité de piloter Internet Explorer
'Elle nécessite la création de 2 requêtes distinctes :
' - la première permet de récupérer la structure du document HTML du site et donc d'accéder à la collection des liens pointant vers les fichiers
' - la seconde traite individuellement chaque lien afin de télécharger le fichier vers le dossier "téléchargement" créé sur le bureau.
'
'============== Points à vérifier ====================================
'Cocher les références suivantes :
'  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 strFileURL As String = "http://data.hgca.com/archive/futures/xls/" 'préfixe de l'URL des fichiers
Const strFolderName As String = "téléchargement" 'nom du dossier

'adapté de http://www.developpez.net/forums/d1442277/logiciels/microsoft-office/excel/macros-vba-excel/extraire-l-ensemble-liens-urls-d-page-web/#post7831772
Sub XmlHttpRequest()
Dim oXmlHttp As XmlHttp
Dim HtmlFile As HTMLElementCollection
Dim oColLinks As IHTMLElementCollection
Dim oLink As HTMLAnchorElement
Dim oStream As ADODB.Stream
Dim HtmlDoc As String
Dim strPathName As String
Dim strPathFileName As String

Set oXmlHttp = New XmlHttp

oXmlHttp.Open "GET", strURL, False
oXmlHttp.send

If oXmlHttp.Status = 200 Then HtmlDoc = oXmlHttp.responseText

If HtmlDoc <> vbNullString Then
  strPathName = GetDesktopFolder & "\" & strFolderName & "\" 'chemin du dossier contenant les fichiers
  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 crée un document HTML dans lequel on va recopier la structure HTML de l'URL
  '(contenue sous forme de texte dans la variable HtmlDoc) afin de pointer vers les liens contenus dans la page
  Set HtmlFile = New HTMLDocument 'CreateObject("HTMLFile")
  HtmlFile.write HtmlDoc
  Set oColLinks = HtmlFile.Links 'on accède à la collection des liens
  
  Set oStream = New ADODB.Stream
  oStream.Open
  oStream.WriteText HtmlDoc

  For Each oLink In oColLinks 'on accède à chaque lien
    If oLink.innerHTML = "Excel" Then
      strPathFileName = strFileURL & oLink.nameProp
      Call DownloadFile(strPathFileName, strPathName, oLink.nameProp)
    End If
  Next oLink
  
oStream.Close

Set oXmlHttp = Nothing
Set oStream = Nothing
Set oColLinks = Nothing
Set oLink = Nothing
Set HtmlFile = Nothing

MsgBox "Traitement terminé !"
End If
End Sub

Sub DownloadFile(strPathFileName As String, strPathName As String, strFileName)
Dim oStreamFile As ADODB.Stream
Dim oXmlHttpFile As XmlHttp
strFileName = Replace(strFileName, "%20", " ") 'remplacement du %20 retrouvé dans l'URL par l'espace

Set oXmlHttpFile = New XmlHttp
oXmlHttpFile.Open "GET", strPathFileName, False, vbNullString, vbNullString
oXmlHttpFile.send

If oXmlHttpFile.Status = 200 Then
  Set oStreamFile = New ADODB.Stream
  oStreamFile.Open
  oStreamFile.Type = adTypeBinary ' 1 = no adTypeBinary, 2 = adTypeText
  oStreamFile.write oXmlHttpFile.responseBody
  oStreamFile.SaveToFile strPathName & strFileName, adSaveCreateOverWrite ' 1 = no overwrite, 2 = overwrite
  oStreamFile.Close
End If

Set oXmlHttpFile = Nothing
Set oStreamFile = Nothing
End Sub

Function GetDesktopFolder()
Dim oShell As WshShell
  Set oShell = New WshShell
  GetDesktopFolder = oShell.SpecialFolders("Desktop")
End Function

Cela fonctionne correctement chez moi (Excel 2010 64 bits + Windows7).
Merci à ED31 et à tous ceux qui veulent bien tester de me dire si cela fonctionne sur leur ordinateur (préciser leur version d'Excel et leur système d'exploitation).
A+

Cliquez pour agrandir...