使用 VBA 在 Excel 中实现图片自动下载
1. 准备
1.1 MSXML2.XMLHTTP
XmlHttp 提供客户端同 http 服务器通讯的协议
1.2 ADODB.Stream
ADODB.Stream 属于 ADODB 组件中的一个对象，它是一种数据流对象，用于处理二进制数据流
2. MSXML2.XMLHTTP 介绍
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 介绍
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
' 最后要执行的行
Dim lastRow As Integer
' 遍历的变量
Dim i As Integer
' 图片存放的目录
Dim path As String
' 计数
Dim count As Integer
' 初始化
count = 0
' 创建 XMLHTTP 对象
Set objXmlHttp = CreateObject("MSXML2.XMLHTTP")
' 定位到 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
' 从第 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
count = count + 1
End If
Next
errorStep:
' 判断成功错误与否，弹出提示信息
If Err.Description <> "" Then
MsgBox (Err.Description), vbCritical, "下载图片"
Else
MsgBox ("下载成功，共执行 " & count & " 条记录！"), vbInformation, "下载图片"
End If
clearStep:
' 恢复用户界面交互
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Interactive = True
' 释放 XMLHTTP 对象
Set objXmlHttp = Nothing
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
标签：文件,VBA,XMLHTTP,Stream,URL,并重,对象,字符串,path From： https://www.cnblogs.com/wuze-blog/p/18302092