VBA与网抓

信息时代已经到来，该如何好好利用网络资源？

爬虫的话首选Python，无奈，对于我这样半道出家非专业编程的工程人来说，学习成本确实是个问题。好在VB是当年微软的主推，支持的库不是最新最先进，但起码还有的用用。抛开效率不讲，VB当之无愧的是工程人员的首选。

首先关于网抓应该先了解两样工具：

一个是浏览器的F12调出来的开发人员工具。
另一个是大名鼎鼎的Fiddler。
这两个工具用来分析网页。

当然，对于HTML的知识也是不能少的啦。

可以参考：http://www.w3school.com.cn/html/index.asp

VBA网抓常用的方法有：

1、xmlhttp/winhttp法：
用xmlhttp/winhttp模拟向服务器发送请求，接收服务器返回的数据。
优点：效率高，基本无兼容性问题。
缺点：需要借助如fiddler的工具来模拟http请求。
2、IE/webbrowser法：
创建IE控件或webbrowser控件，结合htmlfile对象的方法和属性，模拟浏览器操作，获取浏览器页面的数据。
优点：这个方法可以模拟大部分的浏览器操作。所见即所得，浏览器能看到的数据就能用代码获取。
缺点：各种弹窗相当烦人，兼容性也确实是个很伤脑筋的问题。上传文件在IE里根本无法实现。
3、QueryTables法：
因为它是excel自带，所以勉强也算是一种方法。其实此法和xmlhttp类似，也是GET或POST方式发送请求，然后得到服务器的response返回到单元格内。
优点：excel自带，可以通过录制宏得到代码，处理table很方便
。代码简短，适合快速获取一些存在于源代码的table里的数据。
缺点：无法模拟referer等发包头
引自：http://club.excelhome.net/thread-1159783-1-1.html

直接上代码：

对于xmlhttp法

Public Function XmlHttpData(LinkString As String) As String

Dim xmlHttp As Object
Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
xmlHttp.Open "GET", LinkString, False
xmlHttp.send

Do While xmlHttp.readystate <> 4
    DoEvents
Loop

XmlHttpData = xmlHttp.ResponseText
End Function

乱码的处理：

XmlHttpData = StrConv(xmlHttp.ResponseText, vbUnicode)

最后是分析返回的数据

处理table：
可以使用split以及replace分析
或者通过正则表达式分析。
还有：
html法
将table数据写入htmldocument对象，然后循环取出表格的各个元素。

Sub Main()
Dim strText As String
Dim arrData(1 To 1000, 1 To 3)
Dim i As Long, j As Long
Dim TR As Object, TD As Object

With CreateObject("MSXML2.XMLHTTP")
    .Open "POST", "http://www.pinble.com/Template/WebService1.asmx/Present3DList", False
    .setRequestHeader "Content-Type", "application/json"
    .Send "{pageindex:'1',lottory:'TC7XCData_jiangS',pl3:'',name:'江苏七星彩',isgp: '0'}"
    strText = Split(JSEval(.responsetext), "<script")(0) '本例的script运行会提示错误，所以去除这部分script代码
End With

With CreateObject("htmlfile")
    .write strText
    i = 0
    For Each TR In .all.tags("table")(2).Rows
        i = i + 1
        j = 0
        For Each TD In TR.Cells
            j = j + 1
            arrData(i, j) = TD.innerText
        Next
    Next
End With

Set TR = Nothing
Set TD = Nothing
Cells.Clear
Range("C:C").NumberFormat = "@"  
Range("a1").Resize(i, 3).Value = arrData
End Sub

Function JSEval(s As String) As String
With CreateObject("MSScriptControl.ScriptControl")
    .Language = "javascript"
    JSEval = .Eval(s)
End With
End Function

QueryTable法

    Sub Main()
    Cells.Delete
    With ActiveSheet.QueryTables.Add("url;http://data.bank.hexun.com/lccp/jrxp.aspx", Range("a1"))
        .WebFormatting = xlWebFormattingNone '不包含格式'
        .WebSelectionType = xlSpecifiedTables '指定table模式'
        .WebTables = "2" '第2张table'
        .Refresh False
    End With
    End Sub

复制粘贴法：
table部分的文字可以直接复制到单元格内，且保留数据原格式。

Sub Main()
Dim strText As String
With CreateObject("MSXML2.XMLHTTP")
    .Open "GET", "http://data.bank.hexun.com/lccp/jrxp.aspx", False
    .Send
    strText = .responsetext
End With
strText = "<table" & Split(Split(strText, "<table")(2), "</table>")(0) & "</table>"
CopyToClipbox strText
Cells.Clear
Range("a1").Select
ActiveSheet.Paste
End Sub

Sub CopyToClipbox(strText As String)
'文本拷贝到剪贴板'
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    .SetText strText
    .PutInClipboard
End With
End Sub

未完待续

來源：https://www.jianshu.com/p/059fbe8486f9
作者：因思道客