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

在上篇用“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 LongSub 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 NextEnd 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 LongPublic arrSub 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 NextEnd SubSub 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