如何用Excel宏实现批量下载图片？

开发功能-Visual Basic-插入-模块，插入以下代码即可。

无表头，每列分别为：文件名、图片链接、成功状态、文件名为空时的名称，图片会保存到D盘的SaveImagesByExcel文件夹里。

版本一

Option Explicit ' 要求变量声明

Sub SaveImagesByExcel(source As Range, targetFolder As String)
    Dim oXMLHTTP As Object
    Dim oBinaryStream As Object
    Dim adTypeBinary As Long
    Dim adSaveCreateOverWrite As Long
    Dim i As Long
    Dim imagePath As String
    Dim imageUrl As String
    Dim aBytes() As Byte
    Dim fso As Object
    Dim lastRow As Long
    Dim fileName As String
    Dim fileExtension As String
    
    adTypeBinary = 1
    adSaveCreateOverWrite = 2
    
    Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP.6.0")
    Set oBinaryStream = CreateObject("ADODB.Stream")
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    On Error GoTo HTTPError
    
    lastRow = source.Rows.Count
    
    For i = 1 To lastRow
        ' 检查第三列单元格是否为"图片成功下载"，是的话直接跳过
        If source.Cells(i, 3).Value = "图片成功下载" Then
            GoTo NextIteration
        End If
        
        ' 检查第二列单元格是否为空，为空则跳过
        If source.Cells(i, 2).Value = "" Then
            GoTo NextIteration
        End If
        
        ' 检查第一列单元格是否为空，为空则使用 "NoFileName_" 前缀
        If source.Cells(i, 1).Value = "" Then
            ' 使用图片名称作为文件名
            fileName = GetFileNameFromURL(source.Cells(i, 2).Value)
            ' 如果文件名没有后缀名，则添加 ".jpg" 后缀
            If InStr(fileName, ".") = 0 Then
                fileName = "NoFileName_" & fileName & ".jpg"
            Else
                fileName = "NoFileName_" & fileName
            End If
            ' 在第四列显示文件名和后缀
            source.Cells(i, 4).Value = fileName
        Else
            fileName = source.Cells(i, 1).Value ' 使用第一列的内容作为图片名字
            ' 在第四列显示空白
            source.Cells(i, 4).Value = ""
        End If
        
        imagePath = targetFolder & "\" & fileName
        
        imageUrl = source.Cells(i, 2).Value ' 获取图片下载地址
        
        If Not fso.FolderExists(targetFolder) Then ' 检查目标文件夹是否存在
            If fso.DriveExists(Left(targetFolder, 1)) Then ' 检查目标驱动器是否存在
                fso.CreateFolder targetFolder ' 如果目标文件夹不存在，创建它
            Else
                targetFolder = "C:\SaveImagesByExcel\" ' 如果目标驱动器不存在，将目标文件夹路径更改为C盘下的SaveImagesByExcel文件夹
                fso.CreateFolder targetFolder ' 创建SaveImagesByExcel文件夹
            End If
        End If
        
        oXMLHTTP.Open "GET", imageUrl, False
        oXMLHTTP.Send
        If oXMLHTTP.Status = 200 Then ' 如果HTTP状态码为200，表示请求成功
            aBytes = oXMLHTTP.responseBody
            
            With oBinaryStream
                .Type = adTypeBinary
                .Open
                .Write aBytes
                .SaveToFile imagePath, adSaveCreateOverWrite
                .Close
            End With
            
            ' 在第三列显示下载状态
            source.Cells(i, 3).Value = "图片成功下载"
        End If
NextIteration:
    Next i
    
    MsgBox "所有图片已成功下载至指定文件夹。"
    Exit Sub

HTTPError:
    ' 在第三列显示下载状态
    source.Cells(i, 3).Value = "图片下载失败"
    MsgBox "图片下载失败。请检查图片链接。"
    Exit Sub
End Sub

Function GetFileNameFromURL(url As String) As String
    Dim segments() As String
    segments = Split(url, "/")
    GetFileNameFromURL = segments(UBound(segments))
End Function

Sub ChaoSavesImages()
    SaveImagesByExcel Range("A:D"), "D:\SaveImagesByExcel"
End Sub

版本二

Option Explicit ' 要求变量声明

Sub SaveImagesByExcel(source As Range, targetFolder As String)
    Dim oXMLHTTP As Object
    Dim oBinaryStream As Object
    Dim adTypeBinary As Long
    Dim adSaveCreateOverWrite As Long
    Dim i As Long
    Dim imagePath As String
    Dim imageUrl As String
    Dim aBytes() As Byte
    Dim fso As Object
    Dim lastRow As Long
    Dim fileName As String
    Dim fileExtension As String
    
    adTypeBinary = 1
    adSaveCreateOverWrite = 2
    
    Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP.6.0")
    Set oBinaryStream = CreateObject("ADODB.Stream")
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    On Error GoTo HTTPError
    
    lastRow = source.Rows.Count
    
    For i = 1 To lastRow
        ' 检查第三列单元格是否为"图片成功下载"，是的话直接跳过
        If source.Cells(i, 3).Value = "图片成功下载" Then
            GoTo NextIteration
        End If
        
        ' 检查第二列单元格是否为空，为空则跳过
        If source.Cells(i, 2).Value = "" Then
            GoTo NextIteration
        End If
        
        ' 检查第一列单元格是否为空，为空则使用 "NoFileName_" 前缀
        If source.Cells(i, 1).Value = "" Then
            ' 使用图片名称作为文件名
            fileName = GetFileNameFromURL(source.Cells(i, 2).Value)
            ' 如果文件名没有后缀名，则添加 ".jpg" 后缀
            If InStr(fileName, ".") = 0 Then
                fileName = "NoFileName_" & fileName & ".jpg"
            Else
                fileName = "NoFileName_" & fileName
            End If
            ' 在第四列显示文件名和后缀
            source.Cells(i, 4).Value = fileName
        Else
            fileName = source.Cells(i, 1).Value ' 使用第一列的内容作为图片名字
            ' 在第四列显示空白
            source.Cells(i, 4).Value = ""
        End If
        
        imagePath = targetFolder & "\" & fileName
        
        imageUrl = source.Cells(i, 2).Value ' 获取图片下载地址
        
        If Not fso.FolderExists(targetFolder) Then ' 检查目标文件夹是否存在
            If fso.DriveExists(Left(targetFolder, 1)) Then ' 检查目标驱动器是否存在
                fso.CreateFolder targetFolder ' 如果目标文件夹不存在，创建它
            Else
                targetFolder = "C:\SaveImagesByExcel\" ' 如果目标驱动器不存在，将目标文件夹路径更改为C盘下的SaveImagesByExcel文件夹
                fso.CreateFolder targetFolder ' 创建SaveImagesByExcel文件夹
            End If
        End If
        
        oXMLHTTP.Open "GET", imageUrl, False
        oXMLHTTP.Send
        If oXMLHTTP.Status = 200 Then ' 如果HTTP状态码为200，表示请求成功
            aBytes = oXMLHTTP.responseBody
            
            With oBinaryStream
                .Type = adTypeBinary
                .Open
                .Write aBytes
                .SaveToFile imagePath, adSaveCreateOverWrite
                .Close
            End With
            
            ' 在第三列显示下载状态
            source.Cells(i, 3).Value = "图片成功下载"
        End If
NextIteration:
    Next i
    
    MsgBox "所有图片已成功下载至指定文件夹。"
    Exit Sub

HTTPError:
    ' 在第三列显示下载状态
    source.Cells(i, 3).Value = "图片下载失败"
    MsgBox "图片下载失败。请检查图片链接。"
    Exit Sub
End Sub

Function GetFileNameFromURL(url As String) As String
    Dim segments() As String
    segments = Split(url, "/")
    GetFileNameFromURL = segments(UBound(segments))
End Function

Sub ChaoSavesImages()
    Dim targetFolder As String
    Dim folderNumber As Long
    Dim currentDateTime As String
    
    folderNumber = 1
    currentDateTime = Format(Now(), "YYYYMMDD_HHMMSS")
    
    targetFolder = "D:\SaveImagesByExcel\" & folderNumber & "_" & currentDateTime
    
    Do While Dir(targetFolder, vbDirectory) <> "" ' 检查文件夹是否存在，如果存在则递推序号
        folderNumber = folderNumber + 1
        targetFolder = "D:\SaveImagesByExcel\" & folderNumber & "_" & currentDateTime
    Loop
    
    SaveImagesByExcel Range("A:D"), targetFolder
End Sub