VBA爬虫案例

Private Sub 批量获取()
Dim rowTotal!, res$, i!, t!, index!
Dim objXML, objSC, obj, strModel$, queryUrl$, detailUrl$, html, tr, td
Application.ScreenUpdating = False

queryUrl = "http://waybill/trackInfoByCode"
detailUrl = "http://waybill/doQueryReceiver"
strModel = "post"
'Set objSC = CreateObject("ScriptControl"): objSC.Language = "Javascript"
Set html = CreateObject("htmlfile"): html.DesignMode = "on"
rowTotal = [A65536].End(3).Row
Select Case MsgBox("慎用！有可能会被封ERP", 68, "警告")
Case 6
'************登录************
Set objXML = CreateObject("Msxml2.ServerXMLHTTP")
With objXML
.Open "post", "http://ssa.jd/login", False
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/63.0.3239.132 Safari/537.36"
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
D = Sheets("登录").Range("B4")
.send (D)
End With
If InStr(objXML.responsetext, "登录") Then
Sheet2.Activate
MsgBox "登录失败！请检查用户、密码是否正确"
Exit Sub
End If

'获取字段
For i = 2 To rowTotal
If Cells(i, 1) <> "" Then
t = Timer
Do While Timer - 0.1 < t '防止服务器堵塞
DoEvents
Loop

'全程跟踪
res = getHTML(objXML, strModel, queryUrl, "orderCode=&code=" & Cells(i, 1)) '查询返回html文件
html.body.innerHTML = res
Set tr = html.getElementById("grvList").all.tags("tr")
Set td = tr(tr.Length - 1)
For index = 0 To td.Cells.Length - 1
Sheet1.Cells(i, index + 2) = td.Cells(index).innertext
Next index

'运单详情,获取地址
' res = getHTML(objXML, strModel, detailUrl, "opeType=1&waybillCode=VX50932792330" & Cells(i, 1)) '查询返回json字符串
' objSC.addcode ("var obj =" & res)
'进度条
prgramBarShow.Show 0
prgramBarShow.lblprogress.Width = prgramBarShow.lblBack.Width * i / rowTotal
prgramBarShow.percert.Caption = Format(Round(i / rowTotal * 100, 2), "0") & "%"
prgramBarShow.Repaint

End If
Next i
End Select
Unload prgramBarShow
Set objXML = Nothing
Set objSC = Nothing
Set tr = Nothing
Set td = Nothing
Application.ScreenUpdating = True
End Sub
Function getHTML(objXML, strModel, strUrl, sdata)
With objXML
.Open strModel, strUrl, 0
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/63.0.3239.132 Safari/537.36"
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "Accept", "*/*"
.send (sdata)
End With
Do While objXML.Readystate <> 4
DoEvents
Loop
getHTML = objXML.responsetext
End Function
Private Sub 整理格式()
Sheets("查询界面").Range("A2:B65536").ClearContents
Sheets("查询界面").Range("C2:F65536").ClearContents

End Sub