平台版本下限：尚未出现

开发语言：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
'再次判断用户是否要停止运行本程序
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
           If startpage = pagenum Then  '‘如果开始页是当前页面，直接直接从第几条开始提取，否则提取整个页面的记录（50）
                tailnum2 = tailnum
                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
           startrecord = 1
           startpage = startpage + 1
   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
'‘写入运行情况记录’
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

在 VBA 中使用JAVASCRIPT和VBSCRIPT(1)javascript有许多函数和功能可以弥补 VBA 不足，如正则，数组，类，等等1)以数组为例，用JAVASCRIPT排序Subfig8()Setx=CreateObject("msscriptcontrol.scriptcontrol")x.Language="javascript"arr=Array("aa","cc",... 原贴地址：https://blog.csdn.net/u011410413/article/details/54629770 代码会打开IE浏览器逐步操作，和使用python selenium的效果一样。没有找到更换浏览器的方法 Sub aa() url = "http://club.excelhome.net/thread-1466658-1-1.html?tdsourcetag=s_p... 想不到 VBA 也可以爬取 网页 ，说实在话，我也不知道。今天我结合搜索的一些资料和探索，对 VBA 爬取 网页 的2种实现方式做一个全方位和细节解释，相信看完这篇文章的小伙伴会对 VBA 爬取 网页 有一个了解和认知，而且我觉得已经够用了，因为Python在爬取 网页 方面完胜 VBA ，甚至其他编程语言，所以如果真想爬取 网页 ，还是用Python吧。 第一种方法使用Webbrowser控件 相当于在Office里打开一个看得见的IE。优点是实现简单，易于调试，整个 抓 取过程直观可视，易于解决动态 网页 、跨域登录等棘手问题。结合excel Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) ’参数bVk表示要模拟的按键的虚拟码，bScan表示该按键的扫描码(一般可以传0)，dwFlags表示是按下键还是释放键(按下键为0，释放键为2)，dwExtraInfo是扩展标志，一般没有用。 keybd_event VK_Ctrl, 0, 0, 0 需要说明的是 关于"user32"下被 调用 函数的声明，私用常量的声明必需放在 VBA 代码的开头，否则代码不会运行。 抓 取活动窗口的 Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _ bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As 因为要在公司OA系统做报销，每个月的重复工作量非常大，于是想用 vba 实现自动报销功能。利用getElementByid语句已经实现了自动登录功能，但遇到一个瓶颈就是不能利用此语句点击 网页 中的一个链接，若是平时手动点击该链接的话，会弹出一个选择动支单的框框，用了浏览器中F12查看，该链接是。由于是内 网 ，所以无法发 网 址，以下是oa界面的截图。Sub FillAuto()Dim dl As Object... I need to by pass an IE confirm 'OK'/'Cancel' pop-up message. I have a problem running a JavaScript function in my VBA script. My JavaScript:function ConfirmSave(){var Ok = confirm('Are you sure all D... Sub df() Dim pa As Paragraph, re As Object ActiveDocument.Range.Find.Execute "_^13", , , 2, , , , 0, 0, "", 2 '第一个2决定是否通配,第二个决定是否全部替换 Set re = CreateObject("vbscript.regexp") re.Global = STEP1查看是否有Java环境# java --version没有Java的话请先安装# yum install java2. 查看java安装路径# ls -lrt /etc/alternatives/java 3. 修改java配置文件# vim /etc/profile export JAVA_HOME=/usr/lib/jvm/java-11-openjdk-11.0.5.10-0.e... 一、JavaScript简介 网页 、 网 站和应用程序• 网页 ：单独的一个页面。 • 网 站：一系列相关的页面组合到一起。 • 应用程序：可以和用户产生交互，并实现某种功能。1.1 JavaScript用途前端三层 • HTML 结构层 从语义的角度描述页面结构 • css 样式层 从美观的角度描述页面样式 • JavaScript 行为层 ... 特殊 网页 爬虫 —— VBA 开发文档 作者：AntoniotheFuture关键词： VBA ， Access ， 网页 爬虫 ， 网 抓 开发平台： Access 平台版本上限：2010平台版本下限：尚未出现开发语言： VBA 简介：目前在一家保险公司上班，统计数据需要经常从一个公司的 网页 系统中下载报表，操作比较简单，但是要操作的东西太多，比较烦人，对于日常数据的提取，我就想着如果可以定制任务就好了，正好我之前也有过一点点 网页 爬...