VBA 实现从 URL 下载图片并重命名保存

使用 VBA 在 Excel 中实现图片自动下载

1. 准备

1.1 MSXML2.XMLHTTP

XmlHttp 提供客户端同 http 服务器通讯的协议

1.2 ADODB.Stream

ADODB.Stream 属于 ADODB 组件中的一个对象，它是一种数据流对象，用于处理二进制数据流

2. MSXML2.XMLHTTP 介绍

参考：https://www.jianshu.com/p/feba0644e09b

2.1 XMLHTTP 使用步骤

2.1.1 创建XMLHTTP对象

示例

Dim xmlHttp As Object
Set xmlHttp = CreateObject("MSXML2.XMLHTTP")

2.1.2 打开与服务端的连接

示例

xmlHttp.Open "GET", url, false
xmlHttp.setRequestHeader "Connection", "keep-alive"
xmlHttp.setRequestHeader "Content-length", 617

2.1.3 发送指令

示例

xmlHttp.Send

2.1.4 等待并接收响应

示例

Do Until objXmlHttp.ReadyState = 4
    DoEvents
Loop
 
Dim strText AS String
strText = xmlHTTP.reponseText

2.1.5 释放XMLHTTP对象

set xmlHttp = Nothing

2.2 XMLHTTP 方法

open(bstrMethod, bstrUrl, varAsync, bstrUser, bstrPassword)

• bstrMethod: 数据传送方式，即 GET 或 POST。用 POST 方式发送数据，可以达到 4MB，也可以换为 GET，只能 256KB
• bstrUrl: 服务网页的 URL
• varAsync: 是否同步执行。缺省为 true，即同步执行，但只能在 DOM 中实施同步执行，一般将其置为 false，即异步执行
• bstrUser: 用户名，可省略
• bstrPassword: 用户口令，可省略

send(varBody)

• varBody: 指令集。可以是 XML 格式数据，也可以是字符串，流，或者一个无符号整数数组。也可以省略，让指令通过 Open 方法的 URL 参数代入
  发送数据的方式分为同步和异步两种：
  在异步方式下，数据包一旦发送完毕，就结束 Send 进程，客户机执行其他的操作
  而在同步方式下，客户机要等到服务器返回确认消息后才结束 Send 进程

setRequestHeader(bstrHeader, bstrValue)

• bstrHeader: HTTP 头 (header)
• bstrValue: HTTP 头 (header) 的值
• 如果 Open 方法定义为 POST，可以定义表单方式上传：xmlhttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"

abort

• 取消当前 HTTP 请求

getAllResponseHeaders

• 从响应信息中检索所有的标头字段

getResponseHeader

• 从响应信息正文中获得一个 HTTP 标头值

2.3 XMLHTTP 属性

onreadystatechange

• 在同步执行方式下获得返回结果的事件句柄。只能在DOM中调用

readyState

• 反映服务器在处理请求时的进展状况。客户机的程序可以根据这个状态信息设置相应的事件处理方法
• 属性值及其含义如下所示
  0: Response对象已经创建，但XML文档上载过程尚未结束
  1: XML文档已经装载完毕
  2: XML文档已经装载完毕，正在处理中
  3: 部分XML文档已经解析
  4: 文档已经解析完毕，客户端可以接受返回消息

responseBody

• Variant 型 结果返回为无符号整数数组

responseStream

• Variant 型 结果返回为 Stream 流

responseText

• string 型 结果返回为字符串

responseXML

• object 型 结果返回为 XML 格式数据。

status

• Long 型 服务器返回的 HTTP 状态码

statusText

• String 型 服务器 HTTP 响应行状态

3. ADODB.Stream 介绍

参考：https://learn.microsoft.com/en-us/office/client-developer/access/desktop-database-reference/stream-properties-methods-and-events-ado

3.1 ADODB.Stream 方法

open: 打开Stream对象以操作二进制或文本数据流

• 语法: Stream.Open Source, Mode, OpenOptions, UserName, Password
• 参数:
  Source: 可选，一个用于指定数据源的变量值，可能包含一个绝对URL字符串
  Mode: 可选，用于指定结果流的访问模式(例如，读/写或只读)。缺省值为 adModeUnknown
    adModeUnknown(0): 默认，指示权限尚未设置或无法确定
    adModeRead(1): 表示只读权限
    adModeWrite(2): 表示只写权限
    adModeReadWrite(3): 表示读写权限
    adModeShareDenyRead(4): 阻止其他人打开具有读权限的连接
    adModeShareDenyWrite(8): 防止其他人打开具有写权限的连接
    adModeShareExclusive(12): 阻止其他人打开连接
    adModeShareDenyNone(16): 允许其他人以任何权限打开连接，不能拒绝他人的读或写访问
  OpenOptions: 可选，一个 StreamOpenOptionsEnum 值，缺省值为 adOpenStreamUnspecified
    adOpenStreamUnspecified(-1): 默认，指定使用默认选项打开Stream对象
    adOpenStreamAsync(1): 以异步模式打开Stream对象
    adOpenStreamFromRecord(4): 将 Source 视为直接指向树结构中的节点的 URL，打开与该节点关联的默认流
  UserName: 可选，一个字符串值，包含用户标识，如果需要，可以访问 Stream 对象
  Password: 可选，包含密码的 String 值，如果需要，可以访问 Stream 对象

write: 将二进制数据写入流对象

• 语法: Stream.Write Buffer
• 参数:
  Buffer: 包含要写入的字节数组的变量

SaveToFile: 将流的二进制内容保存到文件中

• 语法: Stream.SaveToFile FileName, SaveOptions
• 参数:
  FileName: 一个字符串值，将流内容保存到文件的完全限定名称，可以是任何有效的本地位置，或者通过 UNC 值可以访问的任何位置
  SaveOptions: 一个 SaveOptionsEnum 值，指定如果新文件不存在，是否应该由 SaveToFile 创建，默认值为 adSaveCreateNotExists
    adSaveCreateNotExist(1): 缺省值，如果 FileName 参数指定的文件不存在，则创建一个新文件
    adSaveCreateOverWrite(2): 如果 Filename 参数指定的文件已经存在，则用当前打开的流对象中的数据覆盖该文件

close: 关闭打开的对象和任何依赖对象

• 语法: object.Close

3.2 ADODB.Stream 属性

type

• 指示流中包含的数据类型(二进制或文本)
• 设置和返回值
  设置或返回一个 StreamTypeEnum 值，该值指定 Stream 对象中包含的数据类型
  缺省值为 adTypeText。但是，如果二进制数据最初写入一个新的空流，则 Type 将更改为 adTypeBinary
  adTypeBinary = 1
  adTypeText = 2
• 说明
  Type 属性只有在当前位置位于流的开始 (position 为 0) 时才读取/写入，在其他任何位置都是只读的
  Type 属性确定应该使用哪些方法来读写流。对于文本流，使用 ReadText 和 WriteText，对于二进制流，使用 Read 和 Write

4. 实现图片下载

Excel 工作表 [Sheet1] 内容如下图所示：

按钮 [下载图片] 对应的宏如下

Sub DownLoadPics()
 
    ' 如果运行过程中出错，跳转到 errorStep 处
    On Error GoTo errorStep:
 
        ' 禁用用户界面交互
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        Application.Interactive = False
 
        ' MSXML2.XMLHTTP 对象
        Dim objXmlHttp As Object
        ' ADODB.Stream 对象
        Dim objStream As Object
 
        ' 最后要执行的行
        Dim lastRow As Integer
        ' 遍历的变量
        Dim i As Integer
        ' 图片存放的目录
        Dim path As String
        ' 计数
        Dim count As Integer
        ' 初始化
        count = 0
 
        ' 创建 MSXML2.XMLHTTP 对象
        Set objXmlHttp = CreateObject("MSXML2.XMLHTTP")
        ' 创建 ADODB.Stream 对象
        Set objStream = CreateObject("ADODB.Stream")
 
        ' 定位到 Sheet1 工作表
        Worksheets("Sheet1").Activate
 
        ' 获取图片存储路径
        path = Range("D8").Value
        ' 若未指定路径，则用默认路径（工作簿所在目录）
        If path = "" Then
            path = ThisWorkbook.path
        Else
            ' Dir 函数
            '     当第一次调用 Dir 函数时，它会返回第一个匹配的文件名
            '     如果你再次调用 Dir 函数，不改变参数，它会返回下一个匹配的文件名
            '     当没有更多匹配的文件时，Dir 将返回空字符串
            '     * 格式：Dir([pathname[, attributes]])
            '     * 参数：
            '           pathname 是必选项，一个字符串表达式，它指定了要查找的文件或目录的路径和模式
            '           attributes 是可选项，一个数值表达式，指定了文件的属性
            '               vbNormal (0): 普通文件或目录，这是默认值
            '               vbReadOnly (1): 只读文件
            '               vbHidden (2): 隐藏文件
            '               vbSystem (4): 系统文件
            '               vbVolumeID (8): 卷标
            '               vbDirectory (16): 目录或文件夹
            '               vbArchive (32): 已归档的文件
            '               vbAlias (256): 文件快捷方式（仅适用于 Windows）
            '               可以在 attributes 参数中使用 按位或运算符 (Or) 来组合这些常量，以搜索具有多种属性的文件
            '
            ' Right 函数
            '     可以从字符串的末尾提取指定数量的字符。如果参数设置为1，它将返回最后一个字符
            '
            ' Mid 函数
            '     从给定的字符串中提取子字符串，字符串索引从 1 开始
            '     * 格式：Mid(string, start[, length])
            '
            ' Len 函数
            '     用于返回一个字符串的长度，即字符串中字符的总数
            '     对于非字符串类型的变量，Len 函数返回变量名的长度
            '     * 格式：Len(string_or_variable)
 
            ' 判断目录是否存在，不存在弹出消息框后退出
            ' If Dir(path, vbDirectory) = "" Then
            '     MsgBox ("图片保存目录 不存在！"), vbExclamation, "下载图片"
            '     GoTo clearStep
            ' End If
 
            ' 判断目录是否存在，不存在则创建
            If Dir(path, vbDirectory) = "" Then
                MkDir path
            End If
 
            ' ---------- 下面的路径分隔符处理可以不需要，不影响程序正常运行 ----------
            ' 将路径分隔符中所有“/”，都替换为 “\”
            path = Replace(path, "/", "\")
            ' 判断最后一个字符是否是“\”，是的话舍掉
            If Right(path, 1) = "\" Then
                path = Mid(path, 1, Len(path) - 1)
            End If
        End If
 
        ' 在 B 列上，从最后一行向上寻找，直至找到有值的一行，返回行号
        lastRow = Cells(Rows.count, "B").End(xlUp).Row
 
        ' 打开 Stream 流
        ' 以二进制数据写入流
        objStream.Type = 1
        ' 打开 Stream 对象以操作二进制或文本数据流
        objStream.Open
 
        ' 从第 10 行开始，一直到最后一个有值的一行
        For i = 11 To lastRow
            ' 选中当前操作的单元格，方便判断出错时在哪一行
            Range("B" & i).Select
            ' 判断要操作的行（被“○”标记的行 并且 有 URL 才去下载图片）
            If Range("B" & i).Value = "○" And Range("C" & i).Value <> "" Then
                ' 打开与服务端的连接，同时定义指令发送方式，URL 从 C 列中获取
                objXmlHttp.Open "GET", Range("C" & i).Value, False
                ' 发送指令
                objXmlHttp.Send
                ' 等待并接收服务端返回的处理结果
                Do Until objXmlHttp.ReadyState = 4
                    DoEvents
                Loop
 
                ' 使用 ADODB.Stream 对象写入到本地磁盘（该方式不需要手动创建变量）
                ' With CreateObject("ADODB.Stream")
                '     ' 以二进制数据写入流
                '     .Type = 1
                '     ' 打开 Stream 对象以操作二进制或文本数据流
                '     .Open
                '     ' 将二进制数据写入流对象
                '     .Write objXmlHttp.Responsebody
                '     ' 将内容保存到文件中，第二个参数值（2）表示文件已经存在，则覆盖
                '     .SaveToFile path & "\" & Range("I" & i).Value, 2
                '     ' 关闭打开的对象和任何依赖对象
                '     .Close
                ' End With
 
                ' 避免使用上面的 With 语句块造成 ADODB.Stream 频繁创建与关闭
                ' 将二进制数据写入流对象
                objStream.Write objXmlHttp.Responsebody
                ' 将内容保存到文件中，第二个参数值（2）表示文件已经存在，则覆盖
                objStream.SaveToFile path & "\" & Range("I" & i).Value, 2
 
                ' 成功下载一个，计数加1
                count = count + 1
            End If
        Next
 
errorStep:
    ' 判断成功错误与否，弹出提示信息
    If Err.Description <> "" Then
        MsgBox (Err.Description), vbCritical, "下载图片"
    Else
        MsgBox ("下载成功，共执行 " & count & " 条记录！"), vbInformation, "下载图片"
    End If
 
clearStep:
    ' 判断 Stream 对象是否为空，再去关闭和释放
    If Not objStream Is Nothing Then
        ' 关闭 Stream 流
        objStream.Close
        ' 释放 Stream 对象
        Set objStream = Nothing
    End If
    ' 判断 XMLHTTP 对象是否为空，再去释放
    If Not objXmlHttp Is Nothing Then
        ' 释放 XMLHTTP 对象
        Set objXmlHttp = Nothing
    End If
 
    ' 恢复用户界面交互
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Interactive = True
 
End Sub

5. 测试

(1) 未下载前

(2) 点击 [下载图片] 按钮

(3) 下载后

以上！

---

参考

https://learn.microsoft.com/en-us/office/client-developer/access/desktop-database-reference/stream-properties-methods-and-events-ado
https://www.jianshu.com/p/feba0644e09b
https://blog.csdn.net/chuhe163/article/details/103549144
https://club.excelhome.net/forum.php?mod=viewthread&action=printable&tid=726083&_dsign=e6d94723
https://club.excelhome.net/thread-1196681-1-1.html?_dsign=e9b0dc4c

2024年7月14日22:47:35