网页爬虫实践——VBA调用JS事件

网页爬虫实践——VBA调用JS事件

作者：AntoniotheFuture

关键词：VBA，网页爬虫，网抓，JavaScript，Access

开发平台：Access

平台版本上限：2010

平台版本下限：尚未出现

开发语言：VBA

简介：公司要求我们在双12那天之前做一个可以实时调取系统后台新增保单并自动统计的程序，由于各方面的限制，该数据仅能从一个特定的网页中获取，该网页是一个信息查询网页，查询结果以表格形式展示，且包含分页导航按钮，每次仅显示上下五页范围的按钮，简单的网页爬取方式不太适用。

实际上对于该任务，在公司的机构之间流传着一个同样是用VBA实现的程序，但该程序依靠EXCEL执行，每次循环点击页面执行翻页操作，且每次提取所有记录，保单数量多时，执行效率较低，无法满足公司要求，于是我需要重新设计该爬虫程序（Access+VBA）

本程序可以判断本地的保单信息数量是否与网页中的一致，如果少了就继续调取，相同则等待下一次执行，避免重复调取。

核心代码如下：

Option Compare Database
Public breakornot      '用于检测是否停止运行的全局变量

Private Sub Command2_Click()
'Code written by AntoniotheFuture at 2018-12-01
'Version:V1.0
'Function:爬取并保存网页上的保单清单。
'On Error GoTo delay

Dim dmt, elements, dmt1, a, tr, str, str3,recordnum, pagestr, pagenum, tailnum, startpage, startrecord, tailnum2, m,addnum
'str 页面指示   recordnum 系统记录数    pagenum 系统页数    tailnum 系统尾页记录数      startpage 已有页数      startrecord 已有尾页记录
Dim loop1, loop2, loop3, loop4
Dim t1, t2
Dim Rs, Rs1, Rs4 As ADODB.Recordset
Dim STemp, STemp1 As String
Dim totalpage '总页数

breakornot = 0    
Requery:                      '程序需要循环运行’
If breakornot = 1 Then
   Exit Sub
End If
 
keybd_event 19, 0, 0, 0             '防止屏幕锁屏，此代码需要写一段特定的模块，可百度“VBA防止锁屏”
keybd_event 19, 0, &H2, 0

Set Rs1 = Nothing
Set Rs1 = New ADODB.Recordset

t1 = Time()    
Me.Text16 = "提取数据中"    '界面显示状态

'记录运行状态
STemp1 = "select * From 运行记录"
Rs1.Open STemp1, CurrentProject.Connection,adOpenKeyset, adLockOptimistic
Rs1.AddNew
addnum = 0
Rs1("开始时间")= Date & " " & t1

'目标网页已经在IE打开的前提下，转移网页控制权
Set dmt = Me.WebBrowser0.Object.Document
Set dmt1 = dmt.frames.rightFrame

'填写网页上的查询表单
With dmt1.Document
   .getelementbyid("startDate").Value =Format("2017-12-7", "yyyy-mm-dd")  '预收时间段
   .getelementbyid("endDate").Value =Format("2017-12-8", "yyyy-mm-dd") '预收时间段
   .getelementbyid("regionCode").Value = "1"

    '执行网页上的“onchange和onclick事件”
   .getelementbyid("regionCode").FireEvent "onchange"
   .getelementbyid("q_button").FireEvent "onclick"
End With

'点击查询后网页会有一定延迟，可根据实际情况增删语句
delay 8
Do While Me.WebBrowser0.Object.Busy = True             '‘等待网页加载完毕’
   delay 0.5
   DoEvents
Loop

'再次判断用户是否要停止运行本程序
If breakornot = 1 Then
   Exit Sub
End If

delayout:
Set Rs = Nothing
Set Rs = New ADODB.Recordset
'读取网页查询出来的数据
Set tr = dmt1.Document.getelementsbytagname("table")(4).Rows
STemp = "select * From 预收清单"
Rs.Open STemp, CurrentProject.Connection,adOpenKeyset, adLockOptimistic
   str = GetPageStr                 '‘获取网页中的记录数目’
           If GetPageStr <> "" Then
                recordnum = CInt(Mid(str,InStr(str, "共") + 1, InStr(str, "条") - InStr(str, "共") - 1)) –2                            ‘网页实际记录数’
           End If
    
Me.Text16 = "导入数据中"

pagenum = Fix(recordnum / 50) + 1       '‘计算已有记录换算的页数（50条/页）’
tailnum = recordnum Mod 50                   '‘计算已有记录最后一页的记录数’

   If recordnum = 2 Then                      '‘如果当天还没有单，网页只有两条记录，一条是空行，一条是记录详情，所以直接执行下一次提取。’
       GoTo Requery2
       Exit Sub
   ElseIf recordnum > Rs.RecordCount Then        '‘如果网页记录数大于已有的记录数，就继续
       startpage = Fix(Rs.RecordCount / 50) + 1         '‘开始提取的页数’
       startrecord = Rs.RecordCount Mod 50 + 1       '‘当页开始提取的第几条记录
       Rs.AddNew                                '‘初始化记录
       For loop1 = startpage To pagenum          '‘从开始提取的页到网页总页数’

           dmt1.Document.parentWindow.execScript "goToPage(" &startpage & ")"
'‘核心代码，直接执行网页中的js过程{gotopage}，即翻页’
           delay 0.5
           Do While Me.WebBrowser0.Object.Busy = True
                delay 0.5
                DoEvents
           Loop
           If startpage = pagenum Then  '‘如果开始页是当前页面，直接直接从第几条开始提取，否则提取整个页面的记录（50）
                tailnum2 = tailnum
           Else
                tailnum2 = 50
           End If

    '写入数据到数据库
           For loop2 = startrecord To tailnum2
                Set tr =dmt1.Document.getelementsbytagname("table")(4).Rows
                Rs("业务代码") = tr(loop2).Cells(4).innertext
                Rs("投保单号") = tr(loop2).Cells(8).innertext
                Rs("险种代码") = tr(loop2).Cells(9).innertext
                Rs("保费") = tr(loop2).Cells(10).innertext
                Rs("录入时间") = Format((tr(loop2).Cells(22).innertext), "GeneralDate")
                If tr(loop2).Cells(6).innertext<> " " Then
                     Rs("辅业务员") = tr(loop2).Cells(6).innertext
                End If
                If tr(loop2).Cells(26).innertext <> " " Then
                     Rs("指定生效日") = tr(loop2).Cells(26).innertext
                End If
                Rs.AddNew
                addnum = addnum + 1
           Next
           startrecord = 1
           startpage = startpage + 1
       Next
   Else                                    '‘如果系统记录数等于网页记录数或其他情况，直接下个循环’
       GoTo Requery2
   End If
Rs1.MoveLast
Me.Text6.Requery
Me.Refresh
Requery2:
Me.Text16 = "等待下次刷新"
m = 20                                      '‘根据设定的时间执行下次执行前的倒计时。’
For loop3 = 1 To 20
   If breakornot = 1 Then
   Exit Sub
   End If
    m= m - 1
   Me.Text12 = m
   'Me.Text12.Refresh
   delay 1
Next

'‘写入运行情况记录’
t2 = Time()
Rs1("运行时间（秒）")= DateDiff("s", t1, t2)
Rs1("增加条目数")= addnum
Rs1("总条目数")= DCount("业务代码", "预收清单")
Rs1.MoveLast
Me.Text25 = Rs1("开始时间")
Me.Text28 = Rs1("运行时间（秒）")
Me.Text31 = Rs1("增加条目数")
Rs1.AddNew
GoTo Requery
delay:
delay 10
GoTo delayout
Exit Sub
Rs.Close
Set Rs = Nothing
Rs1.Close
Set Rs1 = Nothing
End Sub



Function GetPageStr()
   Dim str2 As String
   str2 = ""
   str2 =Me.WebBrowser0.Object.Document.frames.rightFrame.Document.getelementsbytagname("table")(5).Rows(0).Cells(0).innertext
   If str2 <> "" Then
       GetPageStr = str2
   End If
End Function