vba - Downloading Images from URL and Renaming

Question

I have an excel sheet with 2 columns, A and B. Column A has a name, and column B has the image URL.

I want to download all the images and have them renamed to what's in column A. I've searched on here and it appears that there has been a previous solution, but the code doesn't work on my version of excel/PC as I get an error:

"Compile Error

The code in the project must be updated for use on 64 bit systems. Please review and update Declare statements then mark them with the PtrSafe Attribute".

Here's the previous post: GET pictures from a url and then rename the picture

Would appreciate and love any help regarding this!

Answer 1

The following Sub should do the same as the one in GET pictures from a url and then rename the picture. But since it does not uses system functions but only native Excel VBA, it should be independent of whether 32-bit or 64-bit Office is used.

The Sheet1:

The code:

Const FolderName As String = "P:Test"

Sub downloadJPGImages()

 Set ws = ActiveWorkbook.Sheets("Sheet1")
 lLastRow = ws.Range("A" & Rows.Count).End(xlUp).Row

 Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP.6.0")
 Set oBinaryStream = CreateObject("ADODB.Stream")
 adTypeBinary = 1
 oBinaryStream.Type = adTypeBinary

 For i = 2 To lLastRow
  sPath = FolderName & ws.Range("A" & i).Value & ".jpg"
  sURI = ws.Range("B" & i).Value

  On Error GoTo HTTPError
  oXMLHTTP.Open "GET", sURI, False
  oXMLHTTP.Send
  aBytes = oXMLHTTP.responsebody
  On Error GoTo 0

  oBinaryStream.Open
  oBinaryStream.Write aBytes
  adSaveCreateOverWrite = 2
  oBinaryStream.SaveToFile sPath, adSaveCreateOverWrite
  oBinaryStream.Close

  ws.Range("C" & i).Value = "File successfully downloaded as JPG"

NextRow:
 Next

 Exit Sub

HTTPError:
 ws.Range("C" & i).Value = "Unable to download the file"
 Resume NextRow

End Sub