Requires a list of links to images for it to work:
The Excel file is set up like this
Function Save_Image_FromWeb()
'Adapted From: http://tipsformarketers.com/use-excel-to-download-hundreds-of-images-instantly/
'Method uses a list of image links to grab each one and download the image (Could also convert to Function and use external loop for the list to call from)
'(((Hard Coded objects for Testing Purposes)))
Dim Ws1 As Long, iLoop As Long, iLinkCol As Long, iDumpImageNameCol As Long, aDump() As Variant, iRe1 As Long, iCe1 As Long
Dim oHTTP As Object, sDestFolder As String, sSrcUrl As String, sImageFile As String
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
Erase aDump
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
iLinkCol = 4
iDumpImageNameCol = 5
iRe1 = 5
iCe1 = 6
Ws1 = Worksheets("Image").Index
'##################################################################
sDestFolder = "E:\Caleb-Backup\WebScrape\MultiplePages_ImageLinks"
'##################################################################
Set oHTTP = CreateObject("msxml2.XMLHTTP")
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'===================================================================================================
Worksheets(Ws1).Select
aDump = Range(Worksheets(Ws1).Cells(1, 1).Address, Worksheets(Ws1).Cells(iRe1, iCe1).Address)
'===================================================================================================
'LLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL
For iLoop = 2 To 4
'LLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL
'Set the Web Link that contains the image
sSrcUrl = aDump(iLoop, iLinkCol)
'Add Web Prefix to string if missing
If Left(sSrcUrl, 2) = "//" Then sSrcUrl = "https:" & sSrcUrl
'Extract the name of the file to save image as (right(link,everything after last [/]))
sImageFile = Right(aDump(iLoop, iLinkCol), Len(aDump(iLoop, iLinkCol)) - InStrRev(aDump(iLoop, iLinkCol), "/"))
'Record the image name in the Array:
aDump(iLoop, iDumpImageNameCol) = sImageFile
'Get the image:
oHTTP.Open "GET", sSrcUrl, False
oHTTP.send
Set oStream = CreateObject("ADODB.Stream")
Const adTypeBinary = 1
Const adSaveCreateOverWrite = 2
oStream.Type = adTypeBinary
oStream.Open
'Save the file:
oStream.write oHTTP.responseBody
oStream.savetofile sDestFolder & "\" & sImageFile, adSaveCreateOverWrite
'LLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL
Next iLoop
'LLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL
'===================================================================================================
'Dump the results:
Worksheets(Ws1).Select
Set Destination = Range(Worksheets(Ws1).Cells(1, 1).Address)
Destination.Resize(UBound(aDump, 1), UBound(aDump, 2)).Value = aDump
'===================================================================================================
gMemoryCleanup:
Set oStream = Nothing
Set oHTTP = Nothing
Erase aDump
End Function
'Adapted From: http://tipsformarketers.com/use-excel-to-download-hundreds-of-images-instantly/
'Method uses a list of image links to grab each one and download the image (Could also convert to Function and use external loop for the list to call from)
'(((Hard Coded objects for Testing Purposes)))
Dim Ws1 As Long, iLoop As Long, iLinkCol As Long, iDumpImageNameCol As Long, aDump() As Variant, iRe1 As Long, iCe1 As Long
Dim oHTTP As Object, sDestFolder As String, sSrcUrl As String, sImageFile As String
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
Erase aDump
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
iLinkCol = 4
iDumpImageNameCol = 5
iRe1 = 5
iCe1 = 6
Ws1 = Worksheets("Image").Index
'##################################################################
sDestFolder = "E:\Caleb-Backup\WebScrape\MultiplePages_ImageLinks"
'##################################################################
Set oHTTP = CreateObject("msxml2.XMLHTTP")
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'===================================================================================================
Worksheets(Ws1).Select
aDump = Range(Worksheets(Ws1).Cells(1, 1).Address, Worksheets(Ws1).Cells(iRe1, iCe1).Address)
'===================================================================================================
'LLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL
For iLoop = 2 To 4
'LLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL
'Set the Web Link that contains the image
sSrcUrl = aDump(iLoop, iLinkCol)
'Add Web Prefix to string if missing
If Left(sSrcUrl, 2) = "//" Then sSrcUrl = "https:" & sSrcUrl
'Extract the name of the file to save image as (right(link,everything after last [/]))
sImageFile = Right(aDump(iLoop, iLinkCol), Len(aDump(iLoop, iLinkCol)) - InStrRev(aDump(iLoop, iLinkCol), "/"))
'Record the image name in the Array:
aDump(iLoop, iDumpImageNameCol) = sImageFile
'Get the image:
oHTTP.Open "GET", sSrcUrl, False
oHTTP.send
Set oStream = CreateObject("ADODB.Stream")
Const adTypeBinary = 1
Const adSaveCreateOverWrite = 2
oStream.Type = adTypeBinary
oStream.Open
'Save the file:
oStream.write oHTTP.responseBody
oStream.savetofile sDestFolder & "\" & sImageFile, adSaveCreateOverWrite
'LLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL
Next iLoop
'LLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL
'===================================================================================================
'Dump the results:
Worksheets(Ws1).Select
Set Destination = Range(Worksheets(Ws1).Cells(1, 1).Address)
Destination.Resize(UBound(aDump, 1), UBound(aDump, 2)).Value = aDump
'===================================================================================================
gMemoryCleanup:
Set oStream = Nothing
Set oHTTP = Nothing
Erase aDump
End Function