Sub 下载糗事百科图片()
Dim b() As Byte
For pagenum = 1 To 15
Dim xmlhttp As Object
Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
strurl = "https://www.qiushibaike.com/pic/" & "page/" & pagenum
xmlhttp.Open "GET", strurl, False
xmlhttp.send
Do While xmlhttp.ReadyState <> 4
DoEvents
Loop
strText = xmlhttp.responseText
Set reg = CreateObject("vbscript.regexp")
reg.Global = True
reg.IgnoreCase = True
reg.MultiLine = True
reg.Pattern = "pic.qiushibaike.com/system/pictures/d+/d+/medium/appd+.jpeg"
Set Match = reg.Execute(strText)
For Each mat In Match
n = n + 1
xmlhttp.Open "GET", "https://" & mat, False
xmlhttp.send
Do While xmlhttp.ReadyState <> 4
DoEvents
Loop
b = xmlhttp.responseBody
Open ThisWorkbook.Path & "图片" & n & ".jpg" For Binary As #1
Put #1, , b
Close
Next
Next
MsgBox "完成"
End Sub说几个知识点： reg.Pattern = "pic.qiushibaike.com/system/pictures/d+/d+/medium/appd+.jpeg"这里是为了通过正则匹配到图片的真实网址。 b = xmlhttp.responseBody
Open ThisWorkbook.Path & "图片" & n & ".jpg" For Binary As #1
Put #1, , b
Close把传输的照片写入图片文件，需要以二进制形式打开并保存。 原文地址：每天学点excel VBA（ID：todatvba）
{var%20f='http://v.t.sina.com.cn/share/share.php?appkey=1515056452',u=z||d.location,p=['&url=',e(u),'&title=',e(t||d.title),'&source=',e(r),'&sourceUrl=',e(l),'&content=',c||'gb2312','&pic=',e(p||'')].join('');function%20a(){if(!window.open([f,p].join(''),'mb',['toolbar=0,status=0,resizable=1,width=440,height=430,left=',(s.width-440)/2,',top=',(s.height-430)/2].join('')))u.href=[f,p].join('');};if(/Firefox/.test(navigator.userAgent))setTimeout(a,0);else%20a();})(screen,document,encodeURIComponent,'','','https://www.xiaopingtou.cn//data/attach/topic/topicKPo7gB.jpg', '推荐 kiroking 的文章《VBA下载糗事百科图片》','https://www.xiaopingtou.net/article-63107.html','页面编码gb2312|utf-8默认gb2312'));){kind=link}