Option Explicit
'code goes in the same worksheet containing your lists
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
Function DownloadFile(URL As String, LocalFileName As String) As Boolean
If URLDownloadToFile(0, URL, LocalFileName, 0, 0) = 0 Then
DownloadFile = True
End If
End Function
'assumes that your URLs are in column a of this worksheet
'and the local filenames to be saved to are in column b
'leave column c blank. will write status of download there
Sub Example()
Dim r As Range
Set r = [a1]
Do Until r = ""
r.Offset(, 2) = DownloadFile(CStr(r.Value), CStr(r.Offset(, 1).Value))
Set r = r.Offset(1)
Loop
End SubOption Explicit
Private Const Folder As String = "C:\Users\Tom\Desktop"
'assumes that your URLs are in A1:A? of this worksheet
Sub Example()
Dim r As Range
Dim ResolvedToLocal As String
Set r = [a1]
Do Until r = ""
r.Offset(, 2) = DownloadFile(CStr(r.Value), ResolvedToLocal)
r.Offset(, 1) = ResolvedToLocal
Set r = r.Offset(1)
Loop
End Sub
Function DownloadFile(ByVal URL As String, Optional ByRef ResolvedToLocal As String) As Boolean
Dim Request As New WinHttpRequest
Dim FileNum As Integer
Dim FileName As String
Dim b() As Byte
On Error GoTo Err_DownloadFile
Request.Open "GET", URL, False
Request.Send
' Debug.Print Request.GetAllResponseHeaders
FileName = Request.GetResponseHeader("Content-disposition")
FileName = Mid(FileName, InStrRev(FileName, "=") + 1)
FileName = Folder & "\" & Replace(FileName, """", "")
ResolvedToLocal = FileName
FileNum = FreeFile
Open FileName For Binary As #FileNum
b() = Request.ResponseBody
Put #FileNum, 1, b()
Close FileNum
DownloadFile = (Request.StatusText = "OK")
Err_DownloadFile:
End Function
Option Explicit
Private Const Folder As String = "C:\Users\Tom\Desktop\Temp"
'assumes that your URLs are in A1:A? of this worksheet
Sub Example()
Dim r As Range
Dim ResolvedToLocal As String
Dim Request As Object
On Error Resume Next
Set Request = CreateObject("WinHttp.WinHttpRequest.5.1")
If Request Is Nothing Then
Set Request = CreateObject("WinHttp.WinHttpRequest.5")
End If
On Error GoTo 0
If Request Is Nothing Then
'WinHttp not installed
Exit Sub
End If
Set r = [a1]
Do Until r = ""
r.Offset(, 2) = DownloadFile(Request, CStr(r.Value), ResolvedToLocal)
r.Offset(, 1) = ResolvedToLocal
Set r = r.Offset(1)
Loop
End Sub
Function DownloadFile(Request As Object, ByVal URL As String, Optional ByRef ResolvedToLocal As String) As Boolean
Dim FileNum As Integer
Dim FileName As String
Dim b() As Byte
On Error GoTo Err_DownloadFile
Request.Open "GET", URL, False
Request.Send
Debug.Print Request.GetAllResponseHeaders
FileName = Request.GetResponseHeader("Content-disposition")
FileName = Mid(FileName, InStrRev(FileName, "=") + 1)
FileName = Folder & "\" & Replace(FileName, """", "")
ResolvedToLocal = FileName
FileNum = FreeFile
Open FileName For Binary As #FileNum
b() = Request.ResponseBody
Put #FileNum, 1, b()
Close FileNum
DownloadFile = (Request.StatusText = "OK")
Err_DownloadFile:
End Function
