VBA Web搜寻器和多线程指南

如果您可以单击这篇文章，那么我们必须是同一个人，我将直接涉及该主题. 本文将概述VBA搜寻器的主要思想，从简单实现到多线程. 您需要具备一些VBA和网络前端基础.

本文中的代码已在WPS的ET形式下经过测试，并且Office Excel也应该没有兼容性问题.

简单来说，有两个共同的想法:

这等效于在Office中打开可见的IE. 优点是易于实现，易于调试，整个爬网过程直观直观，并且易于解决诸如动态网页和跨域登录之类的难题. 缺点是它不灵活，并且某些网页无法处理. 另一个是它非常缓慢. 毕竟，除了通信之外，还需要IE来呈现网页.

方法很简单. 在表单上拖动一个名为oIE的Webbrowser控件. 访问网页和获取信息的几种方法如下:

strURL = "http://foo.com/search.do?keyword=" & strKeyword
oIE.Navigate strURL
Do While oIE.Busy Or (oIE.ReadyState <> 4)
    DoEvents
Loop
'整个HTML response:
Thisworkbook.Sheets("Sheet1").Cells(nRow, nColumn) = oIE.Document.documentElement.outerHTML
'从HTML里截一段，用Mid, InStr InStrRev之类:
Thisworkbook.Sheets("Sheet1").Cells(nRow, nColumn) = Mid(oIE.Document.documentElement.outerHTML, InStr(1, oIE.Document.documentElement.outerHTML, "InfoStart"), 5)
'用ID查找元素:
Thisworkbook.Sheets("Sheet1").Cells(nRow, nColumn) = oIE.Document.getElementById("Name").Value
'找到第2个td元素里的内容(编号从0开始):
Thisworkbook.Sheets("Sheet1").Cells(nRow, nColumn) = oIE.Document.getElementsByTagName("td")(2).innerText

注意: 导航后，您需要等待Webbrowser控件完成，否则导航将再次出错.

优点是它快速且灵活，并且可以实现许多详细信息，例如GET，POST，Header，Cookie等. 缺点是它比Webbrowser麻烦一些，并且调试不直观. 为了轻松引用网页中的信息，您可能希望将XMLhttp的响应文本加载到HTMLfile对象中，该对象可以像Webbrowser一样进行检索. XMLhttp的用法类似于Webbrowser，这是最简单的HTTP GET代码:

Dim oHTTP, oHTML as Object
Set oHTTP = CreateObject("msxml2.xmlhttp.6.0")
Set oHTML = CreateObject("HTMLfile")
strURL = "http://foo.com/search.do?keyword=" & strKeyword
'True是异步模式，访问后需要写个循环等它完成，异步的好处后面说。改成False就是同步模式，Send后不用专门等它
oHTTP.Open "get", strURL, True
oHTTP.Send
Do While oHTTP.ReadyState <> 4
    DoEvents
Loop
'用返回的文本建立一个HTML文档便于查找数据
oHTML.body.innerhtml = oHTTP.responsetext
Thisworkbook.Sheets("Sheet1").Cells(nRow, nColumn) = oHTML.getElementById("Name").Value
Set oHTTP = Nothing
Set oHTML = Nothing

模拟登录的大致代码如下，您可以一目了然:

oIE.Navigate "http://foo.com/login.do"
Do While oIE.Busy Or (oIE.ReadyState <> 4)
    DoEvents
Loop
oIE.Document.getElementById("userName").Value = userName
oIE.Document.getElementById("userPassword").Value = passWord
oIE.Document.getElementById("submitBtn").Click
Do While oIE.Busy Or (oIE.ReadyState <> 4) Or oIE.LocationURL <> "http://foo.com/mainindex.do?method=login&status=1"
    DoEvents
Loop

要点如下:

一一等待，等待网页返回太慢，因此我们不是异步发送一个接一个地等待vba 异步数据，而是使用异步，一次发送一批请求，然后以统一方式等待. 最初的意图当然很好，但是VBA不支持多线程，因此此处的速度提高相对有限，一次发送20个请求只能使速度提高大约2倍. 似乎没有更多用处了. nThread值的选择主要取决于要爬网的网站的速度，建议您通过多次测试来决定.

'一共nThread个请求
For i = 1 To nThread
    Set oHTTP(i) = CreateObject("msxml2.xmlhttp.6.0")
    Set oHTML(i) = CreateObject("HTMLfile")
Next i
For m = 2 To Application.WorksheetFunction.CountA(ThisWorkbook.Sheets("Sheet1").Range("A:A")) - 1 Step nThread
    For i = 1 To nThread
        URL(i) = "http://foo.com/search.do&keyword=" & ThisWorkbook.Sheets("Sheet1").Cells(m + i - 1, 1).Value
        oHTTP(i).Open "get", URL(i), True
        oHTTP(i).Send
        errflag(i) = False
    Next i
    
    '发送后一起等待
    For i = 1 To nThread
        Do While oHTTP(i).ReadyState <> 4
            DoEvents
        Loop
    Next i
    
    For i = 1 To nThread
        oHTML(i).body.innerhtml = oHTTP(i).responsetext
        '简单的出错处理
        If InStr(1, oHTML(i).body.outerhtml, "Error") <> 0 Then
            errflag(i) = True
            If target(i) <> "" Then
                ThisWorkbook.Sheets("sheet1").Cells(m + i - 1, 2).Value = "Error"
            End If
        Else
            errflag(i) = False
            ThisWorkbook.Sheets("sheet1").Cells(m + i - 1, 2).Value = oHTML(i).getElementById("Name").Value
        End If
    Next i
Next m

也许很告诉您VBA不支持多线程. 是的，它确实不支持它，使用该API非常麻烦且不稳定. 但是，Windows操作系统支持多线程，我们使用它来绕过VBA的限制. 不仅有方法，而且有三种.

保存包含宏的工作簿的n个副本，以生成n个VBScript脚本文件. 每个脚本都使用Excel.Application对象打开一个工作簿，在每个工作簿中运行VBA搜寻器，然后将结果写回到主Excel. 此方法有两个优点: 一个是使用字符串的VBScript代码相对简洁，另一个是每个线程都可以使用Webbrowser控件方便地登录. 缺点是打开一批Excel会对系统造成沉重负担.

For nWorker = 1 To cmbWorkers.Value    'cmbWorkers复合框保存了总线程数
    '保存当前工作簿的拷贝
    WorkerFileName = ThisWorkbook.Path & "\~Worker_" & cmbWorkers.Text & "_" & nWorker & ".xlsx"
    Call ThisWorkbook.SaveCopyAs(WorkerFileName)
    
    '写VBS脚本。脚本中调用每个工作簿拷贝里面的宏searchWorker，用参数做好线程之间的分工和数据传递
    s = "Set objExcel = CreateObject(""Excel.Application"")" & vbCrLf
    s = s & "Set objWorkbook = objExcel.Workbooks.Open(""" & WorkerFileName & """)" & vbCrLf
    s = s & "objExcel.Application.Visible = False" & vbCrLf
    s = s & "objExcel.Application.Run ""~Worker_" & cmbWorkers.Value & "_" & nWorker & ".xlsx!searchWorker"" ," & nWorker & "," & cmbWorkers.Text & ",""" & ThisWorkbook.Name & """," & txtStart.Text & ",""" & txtUserName.Text & """,""" & txtPassword.Text & """" & vbCrLf
    s = s & "objExcel.ActiveWorkbook.Close" & vbCrLf
    s = s & "objExcel.Application.Quit" & vbCrLf
    s = s & "Set objExcel = Nothing" & vbCrLf
    
    '保存VBS脚本文件
    scriptFileName = ThisWorkbook.Path & "\~Worker_" & cmbWorkers.Text & "_" & nWorker & ".vbs"
    Open scriptFileName For Output As #1
    Print #1, s
    Close #1
    '异步执行VBS脚本
    Set wsh = VBA.CreateObject("WScript.Shell")
    wsh.Run """" & scriptFileName & """"
    Set wsh = Nothing
Next nWorker

本文来自电脑杂谈，转载请注明本文网址：
http://www.pc-fly.com/a/ruanjian/article-185764-1.html