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

[tony0217]

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.

'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?

 

[John_w]

This downloads the images into the workbook folder.

#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

 

[tony0217]

I recieved an error message on line 27

Compile error:

Sub or function not defined




the following part shows up in red text?

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

 

[John_w]

The error highlights DownloadFile, doesn't it? Sorry, but somehow I omitted the DownloadFile function! Here is the complete 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

 

[John_w]

One little change, if you have the numbers in column C, without the .jpg extension then:

            DownloadFile .Cells(r, "A").Value, saveInFolder & .Cells(r, "C").Value & ".jpg"

 

[tony0217]

the program does run, but im not seeing any files in the directory

 

[tony0217]

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]

Like this:

    saveInFolder = "C:\path\to\folder\"  'CHANGE THIS
    If Right(saveInFolder, 1) <> "\" Then saveInFolder = saveInFolder & "\"

 

[tony0217]

Thank you!
works great