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