Excel VBA爬取网络图片(以图虫为例)

Dim json As New get_json
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
Private Declare Function DeleteUrlCacheEntry Lib "wininet" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
Dim TF As Boolean
Sub TTT()
    TF = True
End Sub

Sub GET_PICID()
    On Error Resume Next
    TF = False
    Application.Calculation = xlCalculationManual
    Sheets("图片ID").Range("A:B").Clear
    Sheets("图片ID").Range("A:B").NumberFormatLocal = "@"
    Dim S As Integer, E As Integer, N As String
    S = InputBox("请输入开始页码(默认是1)", "开始页码", 1)
    E = InputBox("请输入结束页码(默认是1)", "结束页码", 1)
    N = InputBox("请输入查询内容(默认:美女)", "查询内容", "美女")
    For j = S To E
        If TF = True Then Exit For
        Dim ID(0 To 99)
        Dim js As Object
        Set js = CreateObject("ScriptControl")
        js.Language = "JScript"
        js.AddCode "var obj=" & json.GetData("https://stock.tuchong.com/api/free/search/?term=" & json.UrlEncode(N) & "&page=" & j)
        Dim INTT As Integer
        INTT = js.eval("obj.data.size") - 1
        For i = 0 To INTT
            ID(i) = CStr(js.eval("obj.data.hits[" & i & "].imageId"))
        Next
        Sheets("图片ID").Range("A" & Sheets("图片ID").Range("a100000").End(xlUp).Row + 1 & ":A" & Sheets("图片ID").Range("a100000").End(xlUp).Row + 1 + UBound(ID)).Value = WorksheetFunction.Transpose(ID)
        j = j + 1
        DoEvents
    Next
    Call GET_PICURL
    Application.Calculation = xlCalculationAutomatic
End Sub

Sub GET_PICURL()
On Error Resume Next
Dim ARRR, KK
KK = 2
ARRR = Sheets("图片ID").Range("A1:A" & Sheets("图片ID").Range("a100000").End(xlUp).Row).Value
For Each IID In ARRR
    If TF = True Then Exit For
    Dim url As String, TMP As String
    url = "https://stock.tuchong.com/free/image/?imageId=" & IID
    Dim oDom As Object
    Set oDom = CreateObject("HTMLFILE")
    oDom.body.innerHTML = json.GetData(url)
    Set anode = oDom.getElementsByTagName("img")
    For Each XL In anode
        Dim STR As String
        STR = XL.getAttribute("src")
        If InStr(STR, "weili") > 0 Then TMP = Split(STR, "about://")(1)
        DoEvents
    Next
    Dim FILENAME As String
    FILENAME = IID & Right(TMP, 4)
    If DownPicture("http://" & TMP, ThisWorkbook.PATH & "\" & FILENAME) = "失败" Then
        aa = DownPicture("https://" & TMP, ThisWorkbook.PATH & "\" & FILENAME)
    End If
    Sheets("图片ID").Range("B" & KK).Value = "OK"
    KK = KK + 1
    DoEvents
Next
End Sub

Function DownPicture(nUrl As String, PATH As String) As String
    Dim localFilename As String, lngRetVal As Long
    lngRetVal = URLDownloadToFile(0, nUrl, PATH, 0, 0)
    If lngRetVal = 0 Then
        DeleteUrlCacheEntry nUrl    '清除缓存
        DownPicture = "成功"
    Else
        DownPicture = "失败"
    End If
End Function

Public Function GetData(ByVal url As String) As Variant
    On Error GoTo ERR:
    Dim XMLHTTP As Object
    Set XMLHTTP = CreateObject("Microsoft.XMLHTTP")
    XMLHTTP.Open "get", url, True
    XMLHTTP.setrequestheader "Content-Type", "application/json; charset=utf-8"
    XMLHTTP.setrequestheader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:66.0) Gecko/20100101 Firefox/66.0"
    XMLHTTP.send
    While XMLHTTP.ReadyState <> 4
        DoEvents
    Wend
    GetData = XMLHTTP.ResponseText
    Set XMLHTTP = Nothing
    Exit Function
ERR:
    GetData = ERR.Description
End Function

Public Function UrlEncode(ByVal szString As String) As String
    On Error Resume Next
    Dim szChar   As String
    Dim szTemp   As String
    Dim szCode   As String
    Dim szHex    As String
    Dim szBin    As String
    Dim iCount1  As Integer
    Dim iCount2  As Integer
    Dim iStrLen1 As Integer
    Dim iStrLen2 As Integer
    Dim lResult  As Long
    Dim lAscVal  As Long
    szString = Trim$(szString)
    iStrLen1 = Len(szString)
    For iCount1 = 1 To iStrLen1
        szChar = Mid$(szString, iCount1, 1)
        lAscVal = AscW(szChar)
        If lAscVal >= &H0 And lAscVal <= &HFF Then
            If (lAscVal >= &H30 And lAscVal <= &H39) Or _
                (lAscVal >= &H41 And lAscVal <= &H5A) Or _
                (lAscVal >= &H61 And lAscVal <= &H7A) Then
                szCode = szCode & szChar
            Else
                szCode = szCode & "%" & Hex(AscW(szChar))
            End If
        Else
            szHex = Hex(AscW(szChar))
            iStrLen2 = Len(szHex)
            For iCount2 = 1 To iStrLen2
                szChar = Mid$(szHex, iCount2, 1)
                Select Case szChar
                    Case Is = "0"
                        szBin = szBin & "0000"
                    Case Is = "1"
                        szBin = szBin & "0001"
                    Case Is = "2"
                        szBin = szBin & "0010"
                    Case Is = "3"
                        szBin = szBin & "0011"
                    Case Is = "4"
                        szBin = szBin & "0100"
                    Case Is = "5"
                        szBin = szBin & "0101"
                    Case Is = "6"
                        szBin = szBin & "0110"
                    Case Is = "7"
                        szBin = szBin & "0111"
                    Case Is = "8"
                        szBin = szBin & "1000"
                    Case Is = "9"
                        szBin = szBin & "1001"
                    Case Is = "A"
                        szBin = szBin & "1010"
                    Case Is = "B"
                        szBin = szBin & "1011"
                    Case Is = "C"
                        szBin = szBin & "1100"
                    Case Is = "D"
                        szBin = szBin & "1101"
                    Case Is = "E"
                        szBin = szBin & "1110"
                    Case Is = "F"
                        szBin = szBin & "1111"
                    Case Else
                End Select
            Next iCount2
            szTemp = "1110" & Left$(szBin, 4) & "10" & Mid$(szBin, 5, 6) & "10" & Right$(szBin, 6)
            For iCount2 = 1 To 24
                If Mid$(szTemp, iCount2, 1) = "1" Then
                    lResult = lResult + 1 * 2 ^ (24 - iCount2)
                    Else: lResult = lResult + 0 * 2 ^ (24 - iCount2)
                End If
            Next iCount2
            szTemp = Hex(lResult)
            szCode = szCode & "%" & Left$(szTemp, 2) & "%" & Mid$(szTemp, 3, 2) & "%" & Right$(szTemp, 2)
        End If
        szBin = vbNullString
        lResult = 0
    Next iCount1
    UrlEncode = szCode
End Function

源码工具下载链接:
https://www.lanzous.com/i49g5aj