下载任意网址图片（所谓任意，不是所有的）

最新推荐文章于 2024-07-14 19:01:38 发布

原创最新推荐文章于 2024-07-14 19:01:38 发布 · 626 阅读

0 ·

CC 4.0 BY-SA版权

文章标签：

#string #path #url #function #vba #google

本文介绍了一种使用VBA从指定网址批量下载图片的方法，包括直接从单一页面下载所有jpg格式图片，以及通过提取子页面链接来下载更多图片资源的技术细节。

在上篇用“VBA下载google图片”的前提下，想到了下载其它网址图片，经测试，大部分网址可以成功。

Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long Sub cc() Dim s, ss() As String, i&, j& Path = ThisWorkbook.Path & "/" URL = "http://******" On Error Resume Next Sheet1.[IV1] = Sheet1.[IV1] + 1 Set ie = CreateObject("Msxml2.XMLHTTP") ie.Open "GET", URL ie.Send Do Until ie.ReadyState = 4 DoEvents Loop s = Split(ie.responseText, """") For i = 0 To UBound(s) If s(i) Like "http://*" Then If InStr(s(i), "jpg") Then j = j + 1 ReDim Preserve ss(1 To j) ss(j) = s(i) End If End If Next j = 0 MkDir Path & "JPG" & Sheet1.[IV1] For i = 1 To UBound(ss) j = j + 1 URLDownloadToFile 0, ss(i), Path & "JPG" & Sheet1.[IV1] & "/" & j & ".jpg", 0, 0 Next End Sub

有些网站网页图片是层层级级的，可以用下面的代码从总页提取链接下载分页图片

Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long Public arr Sub cc() Dim URL1 As String, URL2 As String, arr() As String, s() As String, r%, i&, j& Path = ThisWorkbook.Path & "/" 'MkDir Path & IName On Error Resume Next URL1 = "http://********" Call dd(URL1) For i = 0 To UBound(arr) If arr(i) Like "********" Then j = j + 1 ReDim Preserve s(1 To j) s(j) = arr(i) End If Next For r = 1 To UBound(s) NUM = Int(Rnd * 200) + 1 MkDir Path & NUM URL2 = "****" & s(r) Call dd(URL2) j = 0 For i = 0 To UBound(arr) If arr(i) Like "http://*" Then If InStr(arr(i), "jpg") Then j = j + 1 URLDownloadToFile 0, arr(i), Path & NUM & "/" & j & ".jpg", 0, 0 End If End If Next Next End Sub Sub dd(URL As String) Set ie = CreateObject("Msxml2.XMLHTTP") ie.Open "GET", URL ie.Send Do Until ie.ReadyState = 4 DoEvents Loop arr = Split(ie.responseText, """") End Sub