Saving images from urls within excel to a directory instead of excel sheet.

tony0217

Board Regular
Joined
Aug 31, 2012
Messages
134
I have a list of urls in column A.

I would like to use those urls to fetch the corresponding image and save it to a directory, and keep the size of the original image as is on the site.
the code I currently have is importing the image into column B, right next to its url.

I'd like to have the image saved as the item number that would be in column C.

Ive seen this done before but some of the example code is very outdated and will not work on my pc..
windows 10, excel 2016.

the item number that would be in column C is the 6 digit code after /300x300.

here are the urls that I am attempting to retrieve the images from. the size of the image is 300x300.

[TABLE="width: 455"]
<tbody>[TR]
[TD]https://www.fragrancenet.com/images/photos/300x300/125716.jpg[/TD]
[/TR]
[TR]
[TD]https://www.fragrancenet.com/images/photos/300x300/121881.jpg[/TD]
[/TR]
[TR]
[TD]https://www.fragrancenet.com/images/photos/300x300/119866.jpg[/TD]
[/TR]
[TR]
[TD]https://www.fragrancenet.com/images/photos/300x300/128244.jpg[/TD]
[/TR]
[TR]
[TD]https://www.fragrancenet.com/images/photos/300x300/218368.jpg[/TD]
[/TR]
</tbody>[/TABLE]



here is the code that i am using to import the images into excel.


Code:
'use url in column A to fetch the image to column b






Sub URLPictureInsert()
Dim Pshp As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next
Application.ScreenUpdating = False
Set Rng = ActiveSheet.Range("A1:A175")
For Each cell In Rng
filenam = cell
ActiveSheet.Pictures.Insert(filenam).Select
Set Pshp = Selection.ShapeRange.Item(1)
If Pshp Is Nothing Then GoTo lab
xCol = cell.Column + 1
Set xRg = Cells(cell.Row, xCol)
With Pshp
.LockAspectRatio = msoFalse
If .Width > xRg.Width Then .Width = xRg.Width * 2 / 3
If .Height > xRg.Height Then .Height = xRg.Height * 2 / 3
.Top = xRg.Top + (xRg.Height - .Height) / 2
.Left = xRg.Left + (xRg.Width - .Width) / 2
End With
lab:
Set Pshp = Nothing
Range("A2").Select
Next
Application.ScreenUpdating = True
End Sub



is this still possible?
 
Last edited:

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.
This downloads the images into the workbook folder.
Code:
#If VBA7 Then
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
    (ByVal pCaller As LongPtr, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As LongPtr) As Long
Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "Wininet.dll" Alias "DeleteUrlCacheEntryA" _
    (ByVal lpszUrlName As String) As Long
]#Else
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
Private Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" Alias "DeleteUrlCacheEntryA" _
    (ByVal lpszUrlName As String) As Long
#End If

Private Const BINDF_GETNEWESTVERSION As Long = &H10


Public Sub Download_Images()
   
    Dim lr As Long, r As Long
    Dim saveInFolder As String
   
    saveInFolder = ThisWorkbook.Path & ""
    If Right(saveInFolder, 1) <> "" Then saveInFolder = saveInFolder & ""
   
    With ActiveSheet
        lr = .Cells(Rows.Count, "A").End(xlUp).row
        For r = 2 To lr
            DownloadFile .Cells(r, "A").Value, saveInFolder & .Cells(r, "C").Value & ".jpg"
        Next
    End With
   
End Sub
 
Last edited by a moderator:
Upvote 0
I recieved an error message on line 27

Compile error:

Sub or function not defined




the following part shows up in red text?
Code:
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
Private Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" Alias "DeleteUrlCacheEntryA" _
    (ByVal lpszUrlName As String) As Long
 
Last edited:
Upvote 0
The error highlights DownloadFile, doesn't it? Sorry, but somehow I omitted the DownloadFile function! Here is the complete code:

Code:
#If VBA7 Then
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
    (ByVal pCaller As LongPtr, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As LongPtr) As Long
Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "Wininet.dll" Alias "DeleteUrlCacheEntryA" _
    (ByVal lpszUrlName As String) As Long
#Else
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
Private Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" Alias "DeleteUrlCacheEntryA" _
    (ByVal lpszUrlName As String) As Long
#End If

Private Const BINDF_GETNEWESTVERSION As Long = &H10


Public Sub Download_Images()
   
    Dim lr As Long, r As Long
    Dim saveInFolder As String
   
    saveInFolder = ThisWorkbook.Path & ""
    If Right(saveInFolder, 1) <> "" Then saveInFolder = saveInFolder & ""
   
    With ActiveSheet
        lr = .Cells(Rows.Count, "A").End(xlUp).row
        For r = 2 To lr
            DownloadFile .Cells(r, "A").Value, saveInFolder & .Cells(r, "C").Value
        Next
    End With
   
End Sub


Private Function DownloadFile(URL As String, LocalFilename As String) As Boolean
   
    Dim retVal As Long
   
    DeleteUrlCacheEntry URL
    retVal = URLDownloadToFile(0, URL, LocalFilename, BINDF_GETNEWESTVERSION, 0)
    If retVal = 0 Then DownloadFile = True Else DownloadFile = False

End Function
 
Last edited by a moderator:
Upvote 0
One little change, if you have the numbers in column C, without the .jpg extension then:
Code:
            DownloadFile .Cells(r, "A").Value, saveInFolder & .Cells(r, "C").Value & ".jpg"
 
Upvote 0
Actually i was wrong.
It did work perfectly!
only thing is that the files are saving on my desktop.
I have the workbook saved in a folder called images on the desktop. how do I change the folder to where i want the images saved?
 
Upvote 0
Like this:
Code:
    saveInFolder = "C:\path\to\folder\"  'CHANGE THIS
    If Right(saveInFolder, 1) <> "\" Then saveInFolder = saveInFolder & "\"
 
Upvote 0

Forum statistics

Threads
1,223,228
Messages
6,170,871
Members
452,363
Latest member
merico17

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top