Save Images To Disk Using the URLs In A Spreadsheet

[miketica]

Hi,

I have a spreadsheet with a bunch of image URLs (A2:A1550). The URL format is
domain.com/blah/123456.jpg or
domain.com/blah/123456.png The numerical part varies (image names are different). I want to save all the images to a local folder, let's say C:\Temp using the name after the last / in the URL as a file name (e.g. 123456.jpg)

Separately, it would be nice to be able to resize those images in Excel to width 567 and height 567 before saving them. The reason why I am asking for this separately is because I am not sure if all the images have the same dimensions (if width=height for all of them) and I do not want them to be cropped.

Thanks

 

[ParamRay]

Try doing it like this:

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

Public Sub Download_Procedure()
  Dim strTargetFolder As String
  Dim strTargetPath As String
  Dim strSourceUrl As String
  Dim lngNumFiles As Long
  Dim lngErrors As Long
  Dim rngUrls As Range
  Dim rngUrl As Range
  
  On Error GoTo ErrHandler
  Set rngUrls = ThisWorkbook.Sheets("Sheet1").Range("A2:A1550") '<-- Set range containing the URLs
  lngNumFiles = rngUrls.Cells.Count
  
  strTargetFolder = "C:\Temp\" '<-- Set target folder
  If Right(strTargetFolder, 1) <> "\" Then strTargetFolder = strTargetFolder & "\"
  If Dir(strTargetFolder, vbDirectory) = "" Then
    MsgBox "Folder does not exist:" & vbCrLf & strTargetFolder, vbExclamation
    Exit Sub
  End If
  
  For Each rngUrl In rngUrls
    On Error GoTo LoopHandler
    strSourceUrl = rngUrl.Value
    strTargetPath = strTargetFolder & FilenameFromUrl(strSourceUrl)
    If Not DownloadFile(strSourceUrl, strTargetPath) Then
      lngErrors = lngErrors + 1
    End If
    GoTo ContinueFor
LoopHandler:
    If Err.Number <> 0 Then
      lngErrors = lngErrors + 1
      Err.Clear
    End If
ContinueFor:
  Next rngUrl
  
  On Error GoTo ErrHandler
  MsgBox Format(lngNumFiles - lngErrors, "#,0") & " files out of " _
       & Format(lngNumFiles, "#,0") & " were downloaded successfully.", vbInformation
  Exit Sub
  
ErrHandler:
  MsgBox Err.Description, vbExclamation
End Sub

Private Function DownloadFile(strSourceUrl As String, strTargetPath As String) As Boolean
  On Error GoTo ErrHandler
  DownloadFile = (URLDownloadToFile(0, strSourceUrl, strTargetPath, 0, 0) = 0)
  Exit Function

ErrHandler:
  DownloadFile = False
End Function

Private Function FilenameFromUrl(strUrl As String) As String
  Dim lngLength As Long
  Dim lngStart As Long
  Dim lngChars As Long
  
  On Error GoTo ErrHandler
  lngLength = Len(strUrl)
  lngStart = InStrRev(strUrl, "/")
  lngChars = lngLength - lngStart
  FilenameFromUrl = Mid(strUrl, lngStart + 1, lngChars)
  Exit Function
  
ErrHandler:
  FilenameFromUrl = ""
End Function