Press ATL+F11
Insert This code
Option Explicit
Sub DownloadImagesWithCustomFilenames()
Dim ws As Worksheet
Dim cell As Range
Dim urlHeader As String
Dim nameHeader As String
Dim folderPath As String
Dim fileName As String
Dim url As String
Dim http As Object
Dim fileStream As Object
Dim successCount As Long
Dim failCount As Long
Dim lastRow As Long
Dim urlCol As Variant
Dim nameCol As Variant
Dim fullPath As String
Dim counter As Long
Dim baseName As String
Dim ext As String
Dim defaultExt As String
Dim dotPos As Long
Set ws = ActiveSheet
' -------------------------------------------------------------------
' CONFIGURATION
' Set these to match your exact Excel header row (Row 1) text
urlHeader = "Photo" ' Column containing AWS links
nameHeader = "Roll Number" ' Column containing custom file names
defaultExt = ".jpg" ' Extension to add if filename lacks one
' -------------------------------------------------------------------
' Find column numbers
urlCol = Application.Match(urlHeader, ws.Rows(1), 0)
If IsError(urlCol) Then
MsgBox "URL Column '" & urlHeader & "' not found in Row 1!", vbCritical, "Error"
Exit Sub
End If
nameCol = Application.Match(nameHeader, ws.Rows(1), 0)
If IsError(nameCol) Then
MsgBox "Filename Column '" & nameHeader & "' not found in Row 1!", vbCritical, "Error"
Exit Sub
End If
' Select target directory
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select Folder to Save Images"
.AllowMultiSelect = False
If .Show = -1 Then
folderPath = .SelectedItems(1) & "\"
Else
MsgBox "Operation cancelled by user.", vbInformation
Exit Sub
End If
End With
' Find last row based on URL column
lastRow = ws.Cells(ws.Rows.Count, urlCol).End(xlUp).Row
If lastRow < 2 Then
MsgBox "No data found under column '" & urlHeader & "'!", vbExclamation
Exit Sub
End If
' Initialize HTTP Object
On Error Resume Next
Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
If http Is Nothing Then Set http = CreateObject("MSXML2.XMLHTTP")
On Error GoTo 0
successCount = 0
failCount = 0
Application.ScreenUpdating = False
Dim i As Long
For i = 2 To lastRow
url = Trim(ws.Cells(i, urlCol).Value)
fileName = Trim(ws.Cells(i, nameCol).Value)
If url <> "" And (Left(LCase(url), 4) = "http") Then
' Fallback if custom filename cell is empty
If fileName = "" Then
fileName = "Image_Row_" & i
End If
' Sanitize invalid Windows filename characters (\ / : * ? " < > |)
fileName = Replace(fileName, "\", "_")
fileName = Replace(fileName, "/", "_")
fileName = Replace(fileName, ":", "_")
fileName = Replace(fileName, "*", "_")
fileName = Replace(fileName, "?", "_")
fileName = Replace(fileName, """", "_")
fileName = Replace(fileName, "<", "_")
fileName = Replace(fileName, ">", "_")
fileName = Replace(fileName, "|", "_")
' Append default extension if filename lacks an extension
If InStr(fileName, ".") = 0 Then
fileName = fileName & defaultExt
End If
' Handle duplicate filenames to avoid overwriting existing files
fullPath = folderPath & fileName
If Dir(fullPath) <> "" Then
dotPos = InStrRev(fileName, ".")
baseName = Left(fileName, dotPos - 1)
ext = Mid(fileName, dotPos)
counter = 1
Do While Dir(folderPath & baseName & "_" & counter & ext) <> ""
counter = counter + 1
Loop
fullPath = folderPath & baseName & "_" & counter & ext
End If
Application.StatusBar = "Downloading Row " & i & " as " & fileName & "..."
On Error Resume Next
http.Open "GET", url, False
http.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64)"
http.send
If http.Status = 200 Then
' Save binary stream to specified path
Set fileStream = CreateObject("ADODB.Stream")
fileStream.Type = 1 ' Binary
fileStream.Open
fileStream.Write http.responseBody
fileStream.SaveToFile fullPath, 2 ' Overwrite/Save
fileStream.Close
Set fileStream = Nothing
successCount = successCount + 1
Else
failCount = failCount + 1
End If
On Error GoTo 0
End If
Next i
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox "Process Finished!" & vbCrLf & vbCrLf & _
"Successfully downloaded: " & successCount & vbCrLf & _
"Failed / Skipped: " & failCount, vbInformation, "Completed"
End Sub
0 comments:
Post a Comment