VBA-Excel图片下载到本地文件夹

操作步骤

1. 打开包含商品信息和图片url的excel
2. Alt+F11进入vba

   3. 复制VBA代码并修改对应的：

        1.图片保存路径，要求路径不存在或者要清空（清空是因为如果已存在对应图片则不会更新），一定要在路径末尾添加“\”。

        2. url所在列（建议使用默认形式，第一列为款号列，第二列为图片URL列）

        3. 图片宽和高也可修改，默认宽为500，长为550

        4. vba代码

Sub DownloadImages()
    Dim rng As Range, cell As Range
    Dim imgUrl As String, savePath As String, fileName As String
    Dim http As Object, stream As Object
    Dim tempFilePath As String
    Dim img As Object
    Dim FSO As Object 
    
    Set http = CreateObject("MSXML2.XMLHTTP")
    Set stream = CreateObject("ADODB.Stream")
    Set img = CreateObject("WIA.ImageFile")
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    savePath = "C:\商品图片\" '修改为实际保存路径，路径末尾一定要加上\
    If Not FSO.FolderExists(savePath) Then FSO.CreateFolder(savePath) 
    
   
    tempFilePath = Environ("Temp") & "\ExcelImages\"
    If Not FSO.FolderExists(tempFilePath) Then FSO.CreateFolder(tempFilePath)
    
    On Error Resume Next
    
    For Each cell In Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row) '图片URL所在列
        imgUrl = cell.Value
        fileName = savePath & cell.Offset(0, -1).Value & ".jpg" '款号列为url列向左偏移一列
        
        
        Dim tempFile As String
        tempFile = tempFilePath & "temp_" & cell.Offset(0, -1).Value & ".jpg"
        
        http.Open "GET", imgUrl, False
        http.Send
        
        If http.Status = 200 Then
            stream.Open
            stream.Type = 1
            stream.Write http.responseBody
            stream.SaveToFile tempFile, 2
            stream.Close
            
            If FSO.FileExists(fileName) Then
                FSO.DeleteFile fileName, True 
            End If
            
            img.LoadFile tempFile
            
            Dim ip As Object
            Set ip = CreateObject("WIA.ImageProcess")
            
            ip.Filters.Add ip.FilterInfos("Scale").FilterID
            With ip.Filters(1).Properties
                .Item("MaximumWidth") = 500 ' 设置最大宽度
                .Item("MaximumHeight") = 550 ' 设置最大高度
                .Item("PreserveAspectRatio") = False
            End With
            
            Dim processedImg As Object
            Set processedImg = ip.Apply(img)
            processedImg.SaveFile fileName
            
            If FSO.FileExists(tempFile) Then
                FSO.DeleteFile tempFile, True
            End If
        End If
    Next cell
    
    If FSO.FolderExists(tempFilePath) Then
        FSO.DeleteFolder tempFilePath, True
    End If
    
    MsgBox "图片下载完成！"
End Sub

1. 点击运行，完成状态显示如下：

对应文件位置会自动生成文件夹及图片（图片大小为url实际的图片大小）