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

本文分享自微信公众号 - VB小源码(vb_xym)

原文出处及转载信息见文内详细说明,如有侵权,请联系 yunjia_community@tencent.com 删除。

原始发表时间:2019-05-23

本文参与腾讯云自媒体分享计划,欢迎正在阅读的你也加入,一起分享。

发表于

我来说两句

0 条评论
登录 后参与评论

相关文章

来自专栏华章科技

Python带你薅羊毛:手把手教你揪出最优惠航班信息

在现实生活中,爬虫的用途完全取决于你。我曾经用它安排过两次假期旅行,还搜索过一些回我老家的短途航班信息。

22620
来自专栏华章科技

网络爬虫法律条文或出台:你的程序合法吗?

2018年10月20日,一篇《独家|估值175亿的旅游独角兽,是一座僵尸和水军构成的鬼城?》的文章一出世便走红网络。文中称百亿体量的马蜂窝,其中2100万条“真...

1.7K20
来自专栏SEO优化知识

百度近期算法调整,“未能抓取成功”不收录怎么办?

毫无疑问,自熊掌号上线以来,百度算法我们几乎认为每天都在调整,从“号”变“ID”虽然,战略层面的因素更多,但相关的搜索权益也在悄然变更。 

10120
来自专栏GoLang那点事

千万级数据如何通过Java分布式导出

业务系统开发中,产品经常提出这样的功能,要求系统系统支持excel格式数据导出,这种功能再常见不过,熟练的程序员可能几个小时就搞定了,然后随着数据量的增加,使用...

35350
来自专栏技术探究-前端、Python、爬虫、数据分析、工具

爬虫系列(10)Scrapy 框架介绍、安装以及使用。

运行命令:scrapy startproject myfrist(your_project_name)

11540
来自专栏SEO优化知识

网站更换域名与重新设计:8个SEO细节!

对于站长而言,每个成功的站点都会经过改版的过程,更换网站域名,重新设计程序与网站模板,但这并不是一个轻松的事情,特别是针对中小企业网站,它面临诸多风险。

10920
来自专栏技术探究-前端、Python、爬虫、数据分析、工具

爬虫系列(1)第一步肯定是先介绍介绍爬虫。

网络爬虫也叫网络蜘蛛,如果把互联网比喻成一个蜘蛛网,那么蜘蛛就是在网上爬来爬去的蜘蛛,爬虫程序通过请求url地址,根据响应的内容进行解析采集数据,比如:如果响应...

12630
来自专栏技术探究-前端、Python、爬虫、数据分析、工具

爬虫系列(14)Scrapy 框架-模拟登录-Request、Response。

通常,Request对象在爬虫程序中生成并传递到系统,直到它们到达下载程序,后者执行请求并返回一个Response对象,该对象返回到发出请求的爬虫程序。

13020
来自专栏技术探究-前端、Python、爬虫、数据分析、工具

爬虫系列(5)更简便Requests请求库使用介绍。

可以通过timeout属性设置超时时间,一旦超过这个时间还没获得响应内容,就会提示错误。

10730
来自专栏python学习教程

python爬虫学习教程,批量抓取美女图片!

python的抓取功能其实是非常强大的,当然不能浪费,呵呵。下面就与大家分享一个python写的美女图自动抓取程序吧!

12830

扫码关注云+社区

领取腾讯云代金券

年度创作总结 领取年终奖励