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

ED31 · 18 Décembre 2014

Bonjour,

A l'ouverture d'un lien http vers un fichier, apparaît un message Office "Ouverture de... Certains fichiers peuvent contenir...Voulez vous ouvrir le fichier ?".

Peut-on valider OK dans une routine Excel VBA ou régler Office pour qu'il n'affiche pas ce message de sécurité ?

Je télécharge des fichiers en boucle et souhaite effectuer cette tâche sans intervention de l'opérateur.

Merci

david84 · 29 Décembre 2014

Re : Ouverture lien http vers fichier dans Excel , supprimer le message d'alerte Offi

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+

ED31 · 29 Décembre 2014

Re : Ouverture lien http vers fichier dans Excel , supprimer le message d'alerte Offi

Re-bonjour,

J'ai une erreur visual basic "impossible d'exécuter une macro visual basic à cause d'une erreur de syntaxe".
J'ai copié ton texte dans un module vierge sans regarder ..

A plus

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+

david84 · 29 Décembre 2014

Re : Ouverture lien http vers fichier dans Excel , supprimer le message d'alerte Offi

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

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+

ED31 · 29 Décembre 2014

Re : Ouverture lien http vers fichier dans Excel , supprimer le message d'alerte Offi

Voici ma version d'Excel: EXCEL 2007 12.0.6425.1000 SP2 MSO 512.0.6425.1000). (Mais nous allons passer prochainement à Excel 2013).

J'ai activé toutes les bibliothèques indiquées dans ton programme, sauf Internet Controls. J'ai activé Internet Assistant. Mais IE semble poser problème. J'ai en effet relancé la macro qui bute sur un "type défini par l'utilisateur" à la ligne:
Function WaitIE(oIE As InternetExplorer, Optional pTimeOut As Long = 0) As Boolean

Reste que tes deux macros ont marché la première fois, sauf problème de fichier xls illisibles.

Merci encore.

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+

david84 · 29 Décembre 2014

Re : Ouverture lien http vers fichier dans Excel , supprimer le message d'alerte Offi

Est-ce que tu as testé mon fichier ? Si oui la macro fonctionne-t-elle ?
Normalement toutes les bibliothèques sont cochées dans mon fichier : est-ce le cas ?

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

Là tu parles de ce que tu as fait dans ton fichier non ?
Tu dois l'activer. Pour cela il te suffit de créer un UserForm : place le curseur sur le nom d'une feuille ou d'un module=>clic droit=>Insertion=>UserForm. Une fois créée regarde dans Outils=>références : la bibliothèque Microsoft Internet Controls doit être cochée.
Tu peux ensuite supprimer le UserForm.
A+

ED31 · 29 Décembre 2014

Re : Ouverture lien http vers fichier dans Excel , supprimer le message d'alerte Offi

Re-bonsoir.
Microsoft Internet Controls n’était pas dans la liste de bibliothèques proposées chez moi. La procédure par Userform que tu m'as indiquée ne l'a pas fait sortir du bois !
Aussi, j’ai fait une rapide recherche pour le localiser : il semble s’appeler sous Excel 2007, Microsoft Browsers Helper, qui était bien présent dans ma liste. Je l’ai donc coché. Et "Microsoft Internet Controls" apparaît mystérieusement dans ma liste !
Can't find reference to "Microsoft Internet Controls" - Microsoft Community
La macro plante désormais « type défini par l’utilisateur non défini » sur la ligne :
Dim oShell As WshShell
Bien complexe, tout cela !
Bonne soirée.

david84 · 29 Décembre 2014

Re : Ouverture lien http vers fichier dans Excel , supprimer le message d'alerte Offi

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+

ED31 · 29 Décembre 2014

Re : Ouverture lien http vers fichier dans Excel , supprimer le message d'alerte Offi

Re-bonjour,

Cette dernière macro plante EXCEL.
J'ai essayé à nouveau en supprimant le dossier téléchargement : même chose.

A plus

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+

david84 · 29 Décembre 2014

Re : Ouverture lien http vers fichier dans Excel , supprimer le message d'alerte Offi

Cette dernière macro plante EXCEL.

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+

ED31 · 29 Décembre 2014

Re : Ouverture lien http vers fichier dans Excel , supprimer le message d'alerte Offi

Pas possible de repérer la ligne qui bloque
Plantage total, Excel bloqué: CTRL ALT SUPR.
Merci

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+

Staple1600 · 29 Décembre 2014

Re : Ouverture lien http vers fichier dans Excel , supprimer le message d'alerte Offi

Bonsoir à tous

Le code du message #22 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)

EDITION: Bonsoir david84

david84 · 29 Décembre 2014

Re : Ouverture lien http vers fichier dans Excel , supprimer le message d'alerte Offi

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)

Merci JM.
J'ai également testé sur une version Excel 2007 et Windows7 et je n'ai pas rencontré de problème (si ce n'est que j'ai trouvé le temps de téléchargement bien plus long).
@ED31 : essaie de tester le dernier code sur un autre ordinateur pour voir.
A+

david84 · 1 Janvier 2015

Re : Ouverture lien http vers fichier dans Excel , supprimer le message d'alerte Offi

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+

ED31 · 2 Janvier 2015

Re : Ouverture lien http vers fichier dans Excel , supprimer le message d'alerte Offi

Bonjour David et tous mes meilleurs voeux pour 2015 !

La dernière version est bloqué "variable non définie par l'utilisateur" sur :
Dim HtmlFile As HTMLElementCollection

J'ai bien coché les bibliothèques demandées par la cartouche dans l'éditeur de macros.

Que veut-dire dans la cartouche ,
"et remplacer le nom des types d'énumération par leur valeur numérique" ?

Merci

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+

david84 · 2 Janvier 2015

Re : Ouverture lien http vers fichier dans Excel , supprimer le message d'alerte Offi

Bonjour,
teste ce fichier et dis-moi si cela fonctionne.
Un message permettant de suivre la progression du téléchargement a été rajouté dans la barre d'état (en bas à gauche).
A+

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

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Junior

XLDnaute Barbatruc

Pièces jointes

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Junior

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Junior

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Partager cette page

Statistiques des forums