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.

https://www.fragrancenet.com/images/photos/300x300/125716.jpg
https://www.fragrancenet.com/images/photos/300x300/121881.jpg
https://www.fragrancenet.com/images/photos/300x300/119866.jpg
https://www.fragrancenet.com/images/photos/300x300/128244.jpg
https://www.fragrancenet.com/images/photos/300x300/218368.jpg

<tbody>
</tbody>



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

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,769
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
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
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
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  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
 

tony0217

Board Regular
Joined
Aug 31, 2012
Messages
134
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:

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,769
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
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
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
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  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
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,769

ADVERTISEMENT

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"
 

tony0217

Board Regular
Joined
Aug 31, 2012
Messages
134

ADVERTISEMENT

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?
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,769
Like this:
Code:
    saveInFolder = "C:\path\to\folder\"  'CHANGE THIS
    If Right(saveInFolder, 1) <> "\" Then saveInFolder = saveInFolder & "\"
 

Watch MrExcel Video

Forum statistics

Threads
1,130,191
Messages
5,640,757
Members
417,165
Latest member
Hilders1

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
Top