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 · 6 Janvier 2015

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

Bonsoir,

pour ceux que le sujet intéresse, voici une autre solution via l'utilisation de l'API URLDownloadToFile.
L'utilisation de cette API remplace la 2ème requête (code plus court) :

Code:

Option Explicit

#If Win64 Then
  Private Declare PtrSafe Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean 
  Private Declare PtrSafe Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean 
  Private Declare PtrSafe 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
#Else
  Private Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
  Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
  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
#End If


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_Api()
Dim oXmlHttp As Object
Dim HtmlFile As Object
Dim oColLinks As Object
Dim oLink As Object
Dim oStream As Object
Dim HtmlDoc As String
Dim strPathName As String
Dim strPathFileName As String
Dim strFileName As String
Dim Debut As Currency, Fin As Currency, Freq As Currency
Dim NbFile As Long


QueryPerformanceCounter Debut
Set oXmlHttp = CreateObject("Microsoft.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 = CreateObject("HTMLFile")
  HtmlFile.write HtmlDoc
  Set oColLinks = HtmlFile.Links 'on accède à la collection des liens
  
  Set oStream = CreateObject("ADODB.Stream")
  oStream.Open
  oStream.WriteText HtmlDoc
  oStream.Close


  For Each oLink In oColLinks 'on accède à chaque lien
    If oLink.innerHTML = "Excel" Then
      NbFile = NbFile + 1
      Application.StatusBar = "Téléchargement du fichier n° " & NbFile
      strPathFileName = strFileURL & oLink.nameProp
      strFileName = Replace(oLink.nameProp, "%20", vbNullString)
      DoEvents
      URLDownloadToFile 0, strPathFileName, strPathName & strFileName, 0, 0
      DoEvents
    End If
  Next oLink
  
  Set oXmlHttp = Nothing
  Set oStream = Nothing
  Set oColLinks = Nothing
  Set oLink = Nothing
  Set HtmlFile = Nothing
  
  QueryPerformanceCounter Fin
  QueryPerformanceFrequency Freq
  
  Application.StatusBar = "Téléchargement terminé !"
  MsgBox "Fichiers téléchargés en " & Format((Fin - Debut) / Freq, "0.00 s")
  Application.StatusBar = False
End If
End Sub


Function GetDesktopFolder()
Dim oShell As Object
  Set oShell = CreateObject("WScript.Shell")
  GetDesktopFolder = oShell.SpecialFolders("Desktop")
End Function

La vitesse de téléchargement est légèrement améliorée (mais à vous de me le confirmer).

Et pour ceux qui sont sages je vous présenterai demain une autre façon de faire.
Et là ça va beaucoup plus vite...
A+

JCGL · 6 Janvier 2015

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

Bonjour à tous,
Salut Frérot,

Moi je suis sage, très sage.

A la première passe : très long 290.83 secondes
A la deuxième passe : 6.8 secondes
A la troisième passe et après avoir supprimé le répertoire "Téléchargement" : 7.9 secondes

A++ mon ami
A+ à tous

david84 · 7 Janvier 2015

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

Bonsoir,

Jean-Claude, comme je ne peux rien te refuser je livre cette dernière version car :
- tu as effectivement été très sage
- on ne refuse rien à son frérot
- grâce à toi je sais enfin utiliser les screenshots

Mais tout d'abord, rendons à César ce qui lui revient car l'idée de base n'est pas de moi (et quoi qu'on en dise c'est la manière d'aborder le sujet qui est le plus important, sa mise en oeuvre ne venant qu'en second).

Je résume l'idée de base mais je vous encourage à lire le lien indiqué :

dans le cadre de requêtes multiples via VBA le traitement ne peut être que séquentiel (on traite complètement la requête 1, puis la requête 2, etc.). C'est bien sûr efficace mais cela peut prendre un certain temps pour ne pas dire un temps certain.

L'originalité de la procédure est le fait de lancer la requête permettant de se connecter au site via VBA puis d'utiliser ensuite des requêtes multiples grâce à l'utilisation d'un fichier VBScript créé dynamiquement.

Cette procédure lancée par le biais de ce fichier VBScript permet de traiter des requêtes multiples en parallèle, d'où un gain de temps important.

Vous remarquerez d'ailleurs que le dossier "téléchargement" se remplit "à son rythme" alors que la procédure est terminée depuis longtemps. C'est d'ailleurs un paramètre à prendre en compte si l'on veut intégrer cette procédure dans un cadre plus global.

A tester donc de votre côté, en espérant vos retours de tests...

Code:

Option Explicit

#If Win64 Then
  Private Declare PtrSafe Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
  Private Declare PtrSafe Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
#Else
  Private Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
  Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
#End If


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


'http://www.developpez.net/forums/d1410670/logiciels/microsoft-office/excel/contribuez/accelerer-requete-multiples-pages-web/
Sub XmlHttpRequest_VBScript()
Dim oXmlHttp As Object
Dim HtmlFile As Object
Dim oColLinks As Object
Dim oLink As Object
Dim oStream As Object
Dim HtmlDoc As String
Dim strPathName As String
Dim strPathFileName As String
Dim strFileName As String
Dim strFullPathName As String
Dim Debut As Currency, Fin As Currency, Freq As Currency
Dim NbFile As Long
Dim strPathVBScript As String
Dim strVBScriptName As String


QueryPerformanceCounter Debut
Set oXmlHttp = CreateObject("Microsoft.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
  
  strPathVBScript = ScriptFile
  strVBScriptName = """" & strPathVBScript & """ "
  
  '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 = CreateObject("HTMLFile")
  HtmlFile.Write HtmlDoc
  Set oColLinks = HtmlFile.Links 'on accède à la collection des liens
  
  Set oStream = CreateObject("ADODB.Stream")
  oStream.Open
  oStream.WriteText HtmlDoc
  oStream.Close


  For Each oLink In oColLinks 'on accède à chaque lien
    If oLink.innerHTML = "Excel" Then
      NbFile = NbFile + 1
      Application.StatusBar = "Téléchargement du fichier n° " & NbFile
      strPathFileName = strFileURL & oLink.nameProp
      strFileName = Replace(oLink.nameProp, "%20", vbNullString)
      strFullPathName = strPathName & strFileName
      CreateObject("WScript.Shell").Run strVBScriptName & strPathFileName & " " & strFullPathName
    End If
  Next oLink
  
  Set oXmlHttp = Nothing
  Set oStream = Nothing
  Set oColLinks = Nothing
  Set oLink = Nothing
  Set HtmlFile = Nothing
  
  QueryPerformanceCounter Fin
  QueryPerformanceFrequency Freq
  
  Application.StatusBar = "Téléchargement terminé !"
  MsgBox "Fichiers téléchargés en " & Format((Fin - Debut) / Freq, "0.00 s")
  Kill strPathVBScript
 Application.StatusBar = False
End If
End Sub


Function ScriptFile()
Dim Script_vbs As String, SC As String, F As Integer
  Script_vbs = ThisWorkbook.Path & "\Download.vbs"


  SC = "Dim xHttp: Set xHttp = CreateObject(""Microsoft.XMLHTTP"")" & vbCrLf
  SC = SC & "Dim bStrm: Set bStrm = CreateObject(""Adodb.Stream"")" & vbCrLf
  SC = SC & "xHttp.Open ""GET"", WScript.Arguments(0), False" & vbCrLf
  SC = SC & "xHttp.send" & vbCrLf
  SC = SC & "With bStrm" & vbCrLf
  SC = SC & ".Type = 1" & vbCrLf
  SC = SC & ".Open" & vbCrLf
  SC = SC & ".write xHttp.responseBody" & vbCrLf
  SC = SC & ".SaveToFile WScript.Arguments(1), 2" & vbCrLf
  SC = SC & "End With"


  F = FreeFile
  Open Script_vbs For Output As #F
  Print #F, SC
  Close #F
  ScriptFile = Script_vbs
End Function


Function GetDesktopFolder()
Dim oShell As Object
  Set oShell = CreateObject("WScript.Shell")
  GetDesktopFolder = oShell.SpecialFolders("Desktop")
End Function

A+

ED31 · 7 Janvier 2015

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

David

La version n-2 marche bien. C'est bien utile. Mais toujours intéressant d'aller plus vite.

david84 à dit:

Bonsoir,

Jean-Claude, comme je ne peux rien te refuser je livre cette dernière version car :
- tu as effectivement été très sage
- on ne refuse rien à son frérot
- grâce à toi je sais enfin utiliser les screenshots

Mais tout d'abord, rendons à César ce qui lui revient car l'idée de base n'est pas de moi (et quoi qu'on en dise c'est la manière d'aborder le sujet qui est le plus important, sa mise en oeuvre ne venant qu'en second).

Je résume l'idée de base mais je vous encourage à lire le lien indiqué :

dans le cadre de requêtes multiples via VBA le traitement ne peut être que séquentiel (on traite complètement la requête 1, puis la requête 2, etc.). C'est bien sûr efficace mais cela peut prendre un certain temps pour ne pas dire un temps certain.

L'originalité de la procédure est le fait de lancer la requête permettant de se connecter au site via VBA puis d'utiliser ensuite des requêtes multiples grâce à l'utilisation d'un fichier VBScript créé dynamiquement.

Cette procédure lancée par le biais de ce fichier VBScript permet de traiter des requêtes multiples en parallèle, d'où un gain de temps important.

Vous remarquerez d'ailleurs que le dossier "téléchargement" se remplit "à son rythme" alors que la procédure est terminée depuis longtemps. C'est d'ailleurs un paramètre à prendre en compte si l'on veut intégrer cette procédure dans un cadre plus global.

A tester donc de votre côté, en espérant vos retours de tests...

Code:

Option Explicit

#If Win64 Then
  Private Declare PtrSafe Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
  Private Declare PtrSafe Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
#Else
  Private Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
  Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
#End If


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


'http://www.developpez.net/forums/d1410670/logiciels/microsoft-office/excel/contribuez/accelerer-requete-multiples-pages-web/
Sub XmlHttpRequest_VBScript()
Dim oXmlHttp As Object
Dim HtmlFile As Object
Dim oColLinks As Object
Dim oLink As Object
Dim oStream As Object
Dim HtmlDoc As String
Dim strPathName As String
Dim strPathFileName As String
Dim strFileName As String
Dim strFullPathName As String
Dim Debut As Currency, Fin As Currency, Freq As Currency
Dim NbFile As Long
Dim strPathVBScript As String
Dim strVBScriptName As String


QueryPerformanceCounter Debut
Set oXmlHttp = CreateObject("Microsoft.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
  
  strPathVBScript = ScriptFile
  strVBScriptName = """" & strPathVBScript & """ "
  
  '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 = CreateObject("HTMLFile")
  HtmlFile.Write HtmlDoc
  Set oColLinks = HtmlFile.Links 'on accède à la collection des liens
  
  Set oStream = CreateObject("ADODB.Stream")
  oStream.Open
  oStream.WriteText HtmlDoc
  oStream.Close


  For Each oLink In oColLinks 'on accède à chaque lien
    If oLink.innerHTML = "Excel" Then
      NbFile = NbFile + 1
      Application.StatusBar = "Téléchargement du fichier n° " & NbFile
      strPathFileName = strFileURL & oLink.nameProp
      strFileName = Replace(oLink.nameProp, "%20", vbNullString)
      strFullPathName = strPathName & strFileName
      CreateObject("WScript.Shell").Run strVBScriptName & strPathFileName & " " & strFullPathName
    End If
  Next oLink
  
  Set oXmlHttp = Nothing
  Set oStream = Nothing
  Set oColLinks = Nothing
  Set oLink = Nothing
  Set HtmlFile = Nothing
  
  QueryPerformanceCounter Fin
  QueryPerformanceFrequency Freq
  
  Application.StatusBar = "Téléchargement terminé !"
  MsgBox "Fichiers téléchargés en " & Format((Fin - Debut) / Freq, "0.00 s")
  Kill strPathVBScript
 Application.StatusBar = False
End If
End Sub


Function ScriptFile()
Dim Script_vbs As String, SC As String, F As Integer
  Script_vbs = ThisWorkbook.Path & "\Download.vbs"


  SC = "Dim xHttp: Set xHttp = CreateObject(""Microsoft.XMLHTTP"")" & vbCrLf
  SC = SC & "Dim bStrm: Set bStrm = CreateObject(""Adodb.Stream"")" & vbCrLf
  SC = SC & "xHttp.Open ""GET"", WScript.Arguments(0), False" & vbCrLf
  SC = SC & "xHttp.send" & vbCrLf
  SC = SC & "With bStrm" & vbCrLf
  SC = SC & ".Type = 1" & vbCrLf
  SC = SC & ".Open" & vbCrLf
  SC = SC & ".write xHttp.responseBody" & vbCrLf
  SC = SC & ".SaveToFile WScript.Arguments(1), 2" & vbCrLf
  SC = SC & "End With"


  F = FreeFile
  Open Script_vbs For Output As #F
  Print #F, SC
  Close #F
  ScriptFile = Script_vbs
End Function


Function GetDesktopFolder()
Dim oShell As Object
  Set oShell = CreateObject("WScript.Shell")
  GetDesktopFolder = oShell.SpecialFolders("Desktop")
End Function

A+

david84 · 7 Janvier 2015

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

L'as-tu testé ? Combien de temps prend le téléchargement (indique s'il te plaît la version d'Excel et de ton système d'exploitation).
A+

ED31 · 7 Janvier 2015

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

Non, je suis à la maison.

Mais la version n-2 fonctionne bien. Chargement en 15 minutes, environ (je n'ai pas vérifié) : pas de problème car je peux travailler en même temps.
Excel 2007 et Windows 2005 Pro.

Bonne soirée.

david84 à dit:
L'as-tu testé ? Combien de temps prend le téléchargement (indique s'il te plaît la version d'Excel et de ton système d'exploitation).
A+

JCGL · 7 Janvier 2015

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

Bonjour à tous,
Salut Frérot,

VBA me réclame Script_vbs

A++ l'ami
A+ à tous

david84 · 7 Janvier 2015

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

A quelle ligne il plante ?
A+

david84 · 7 Janvier 2015

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

Modifie la fonction ScriptFile comme cela :

Code:

Function ScriptFile()Dim Script_vbs As String, SC As String, F As Integer
  'Script_vbs = ThisWorkbook.Path & "\Download.vbs"
  Script_vbs = GetDesktopFolder & "\Download.vbs"


  SC = "Dim xHttp: Set xHttp = CreateObject(""Microsoft.XMLHTTP"")" & vbCrLf
  SC = SC & "Dim bStrm: Set bStrm = CreateObject(""Adodb.Stream"")" & vbCrLf
  SC = SC & "xHttp.Open ""GET"", WScript.Arguments(0), False" & vbCrLf
  SC = SC & "xHttp.send" & vbCrLf
  SC = SC & "With bStrm" & vbCrLf
  SC = SC & ".Type = 1" & vbCrLf
  SC = SC & ".Open" & vbCrLf
  SC = SC & ".write xHttp.responseBody" & vbCrLf
  SC = SC & ".SaveToFile WScript.Arguments(1), 2" & vbCrLf
  SC = SC & "End With"


  F = FreeFile
  Open Script_vbs For Output As #F
  Print #F, SC
  Close #F
  ScriptFile = Script_vbs
End Function

A+

JCGL · 7 Janvier 2015

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

Bonjour à tous,

Voici :

A+ à tous

JCGL · 7 Janvier 2015

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

Bonjour à tous,

Plus prompt que l’éclair...

Mise en oeuvre en 5.3 secondes et les fichiers s'incrémentent en 3 minutes
Bravo...

A++
A+ à tous

Edition : Et incrémentation dans la même minute lors d'une deuxième passe...

david84 · 7 Janvier 2015

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

Merci Jean-Claude pour ton retour.
Donc si cela fonctionne tel quel ci-joint la procédure corrigée :

Code:

Option Explicit

#If Win64 Then
  Private Declare PtrSafe Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
  Private Declare PtrSafe Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
#Else
  Private Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
  Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
#End If


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


'http://www.developpez.net/forums/d1410670/logiciels/microsoft-office/excel/contribuez/accelerer-requete-multiples-pages-web/
Sub XmlHttpRequest_VBScript()
Dim oXmlHttp As Object
Dim HtmlFile As Object
Dim oColLinks As Object
Dim oLink As Object
Dim oStream As Object
Dim HtmlDoc As String
Dim strPathName As String
Dim strPathFileName As String
Dim strFileName As String
Dim strFullPathName As String
Dim Debut As Currency, Fin As Currency, Freq As Currency
Dim NbFile As Long
Dim strPathVBScript As String
Dim strVBScriptName As String


QueryPerformanceCounter Debut
Set oXmlHttp = CreateObject("Microsoft.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
  
  strPathVBScript = ScriptFile
  strVBScriptName = """" & strPathVBScript & """ "
  
  '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 = CreateObject("HTMLFile")
  HtmlFile.Write HtmlDoc
  Set oColLinks = HtmlFile.Links 'on accède à la collection des liens
  
  Set oStream = CreateObject("ADODB.Stream")
  oStream.Open
  oStream.WriteText HtmlDoc
  oStream.Close


  For Each oLink In oColLinks 'on accède à chaque lien
    If oLink.innerHTML = "Excel" Then
      NbFile = NbFile + 1
      Application.StatusBar = "Téléchargement du fichier n° " & NbFile
      strPathFileName = strFileURL & oLink.nameProp
      strFileName = Replace(oLink.nameProp, "%20", vbNullString)
      strFullPathName = strPathName & strFileName
      CreateObject("WScript.Shell").Run strVBScriptName & strPathFileName & " " & strFullPathName
    End If
  Next oLink
  
  Set oXmlHttp = Nothing
  Set oStream = Nothing
  Set oColLinks = Nothing
  Set oLink = Nothing
  Set HtmlFile = Nothing
  
  QueryPerformanceCounter Fin
  QueryPerformanceFrequency Freq
  
  Application.StatusBar = "Téléchargement terminé !"
  MsgBox "Fichiers téléchargés en " & Format((Fin - Debut) / Freq, "0.00 s")
  Kill strPathVBScript
 Application.StatusBar = False
End If
End Sub


Function ScriptFile()
Dim Script_vbs As String, SC As String, F As Integer
  Script_vbs = GetDesktopFolder & "\Download.vbs"


  SC = "Dim xHttp: Set xHttp = CreateObject(""Microsoft.XMLHTTP"")" & vbCrLf
  SC = SC & "Dim bStrm: Set bStrm = CreateObject(""Adodb.Stream"")" & vbCrLf
  SC = SC & "xHttp.Open ""GET"", WScript.Arguments(0), False" & vbCrLf
  SC = SC & "xHttp.send" & vbCrLf
  SC = SC & "With bStrm" & vbCrLf
  SC = SC & ".Type = 1" & vbCrLf
  SC = SC & ".Open" & vbCrLf
  SC = SC & ".write xHttp.responseBody" & vbCrLf
  SC = SC & ".SaveToFile WScript.Arguments(1), 2" & vbCrLf
  SC = SC & "End With"


  F = FreeFile
  Open Script_vbs For Output As #F
  Print #F, SC
  Close #F
  ScriptFile = Script_vbs
End Function


Function GetDesktopFolder()
Dim oShell As Object
  Set oShell = CreateObject("WScript.Shell")
  GetDesktopFolder = oShell.SpecialFolders("Desktop")
End Function

A+

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

ED31

XLDnaute Junior

david84

XLDnaute Barbatruc

JCGL

XLDnaute Barbatruc

david84

XLDnaute Barbatruc

ED31

XLDnaute Junior

david84

XLDnaute Barbatruc

ED31

XLDnaute Junior

JCGL

XLDnaute Barbatruc

david84

XLDnaute Barbatruc

david84

XLDnaute Barbatruc

JCGL

XLDnaute Barbatruc

Pièces jointes

JCGL

XLDnaute Barbatruc

david84

XLDnaute Barbatruc

Discussions similaires