Download a set of images from Excel with their names using a macros

Question

I want to run a VBScript macro to download a set of images from an URL which can de sorted by the key , (comma). I have to name each image with names given in the secondary column. For example: I have 2 columns and 5 rows. In column "A" I have all the names of the images and in column "B" I have all the URL links which can be sorted by the ,. Now I want to download all the images with their names in column "A" and for the second set of images it should rename column "A" by adding 2 at the end of each row, and then it should start downloading the second set of images. Same should go for the 3rd set or 4th set until the image set ends. Sometimes there might be only one image URL in column "B".

Here is the script which I tried to download but I was not able to sort the images and download it by renaming it again.

Option Explicit

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

Dim Ret As Long

'~~> This is where the images will be saved. Change as applicable
Const FolderName As String = "C:\Temp\"

Sub Sample()
  Dim ws As Worksheet
  Dim LastRow As Long, i As Long
  Dim strPath As String

  '~~> Name of the sheet which has the list
  Set ws = Sheets("Sheet1")

  LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row

  For i = 2 To LastRow '<~~ 2 because row 1 has headers
    strPath = FolderName & ws.Range("A" & i).Value & ".jpg"

    Ret = URLDownloadToFile(0, ws.Range("B" & i).Value, strPath, 0, 0)

    If Ret = 0 Then
        ws.Range("C" & i).Value = "File successfully downloaded"
    Else
        ws.Range("C" & i).Value = "Unable to download the file"
    End If
  Next i
End Sub

Answer 1

VBScript is not VB, all variables in VBScript are automatically of type Variant and does not directly support API's. It utilizes COM objects instead.

You have to implement a new function that does the same like URLDownloadToFile API call from urlmon.dll.

This should work:

Function URLDownloadToFile(szURL, szFileName, OverWrite)

  On Error Resume Next

  Dim FSO: Set FSO = WScript.CreateObject("Scripting.FileSystemObject")
  Dim ADO_STREAM: Set ADO_STREAM = WScript.CreateObject("ADODB.Stream")
  Dim HTTP: Set HTTP = WScript.CreateObject("Microsoft.XMLHTTP")

  HTTP.Open "GET", CStr(szURL), False
  HTTP.Send

  If Err.Number <> 0 Then
    WScript.Echo "An error has occured, Not connected to a network" + VbCrLf + "Error " + CStr(Err.Number) + ", " + CStr(Err.Description)
    Err.Clear
    URLDownloadToFile = CInt(-1)
    Exit Function
  End If

  With ADO_STREAM
       .Type = 1
       .Open
       .Write HTTP.ResponseBody
       .SaveToFile szFileName, (CInt(OverWrite) + 1)
  End With

  If Err.Number <> 0 Then
    WScript.Echo "URLDownloadToFile failed, Error " + CStr(Err.Number) + VbCrLf + CStr(Err.Description)
    Err.Clear
    URLDownloadToFile = CInt(-1)
    Exit Function
  End If

  If (Err.Number = 0) And (FSO.FileExists(szFileName) = True) Then
    URLDownloadToFile = CInt(0)
  End If

  On Error Goto 0

End Function

Usage of this function:

Ret = URLDownloadToFile(ws.Range("B" & i).Value, strPath, 1)

About OverWrite parameter:

1. Valid values: 0 or 1
2. 1 overwrites existing file and 0 creates a new file if file doesn't exist.

If the file downloaded successfully, above function returns 0 and otherwise it returns -1 (In case any error).

Define following, so you can get the last row in Excel.

'~~> Define xlUp
Const xlUp = -4162

You must create an object referring Excel Application like:

Dim Excel: Set Excel = WScript.CreateObject("Excel.Application")

Use Excel.Sheets, instead of using only Sheets in VB. Example:

Set ws = Excel.Sheets("Sheet1")

IMPORTANT: Change your code as applicable.

Dim Ret

'~~> This is where the images will be saved.
Const FolderName = "E:\TEST\"

Sub Sample()
    Dim ws, LastRow, i, strPath

    '~~> Name of the sheet which has the list
    Set ws = Excel.Sheets("Sheet1")

    LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row

    For i = 2 To LastRow '<~~ 2 because row 1 has headers
        strPath = FolderName & ws.Range("A" & i).Value & ".jpg"

        Ret = URLDownloadToFile(ws.Range("B" & i).Value, strPath, 1) '<~~ 1 to overwrite existing file

        If Ret = 0 Then
          ws.Range("C" & i).Value = "File successfully downloaded"
        Else
          ws.Range("C" & i).Value = "Unable to download the file"
        End If
    Next
End Sub