Option Explicit
Sub test()
Dim mainFolder As String
mainFolder = "c:\users\domenic\desktop\"
If Right(mainFolder, 1) <> "\" Then
mainFolder = mainFolder & "\"
End If
Dim lastRow As Long
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Dim i As Long
Dim destinationFolder As String
Dim url As String
Dim errorMessage As String
For i = 2 To lastRow
destinationFolder = Cells(i, "A").Value
url = Cells(i, "B").Value
If Len(destinationFolder) > 0 And Len(url) > 0 Then
DownloadFile mainFolder & destinationFolder, url
Else
Cells(i, "C").Value = "Item and/or File URL missing"
End If
Next i
MsgBox "Completed!", vbExclamation
End Sub
Public Function DownloadFile(ByVal pathToFolder As String, ByVal url As String, Optional ByRef errorMessage As String = "") As Boolean
On Error GoTo errorHandler
Dim xmlhttp As Object
Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
With xmlhttp
.Open "GET", url, False
.send
Do While .readystate <> 4
DoEvents
Loop
If .Status <> 200 Then
errorMessage = "Error " & .Status & ": " & .statustext
Set xmlhttp = Nothing
DownloadFile = False
Exit Function
End If
Dim response() As Byte
response() = .responsebody
End With
If Right(pathToFolder, 1) <> "\" Then
pathToFolder = pathToFolder & "\"
End If
Dim filename As String
filename = Mid(url, InStrRev(url, "/") + 1)
Dim fileNumber As Long
fileNumber = FreeFile()
Open pathToFolder & filename For Binary As #fileNumber
Put #fileNumber, , response
Close #fileNumber
DownloadFile = True
exitHandler:
Set xmlhttp = Nothing
Exit Function
errorHandler:
errorMessage = "Error " & Err.Number & ":" & vbCrLf & vbCrLf & Err.Description
DownloadFile = False
Resume exitHandler
End Function
