2018-04-15 16:20:27
作者：AntoniotheFuture
關鍵詞：VBA，Access，網頁爬蟲，網抓
開發平臺：Access
平臺版本上限：2010
平臺版本下限：尚未出現
開發語言：VBA
簡介：目前在一家保險公司上班，統計數據需要經常從一個公司的網頁系統中下載報表，操作比較簡單，但是要操作的東西太多，比較煩人，對于日常數據的提取，我就想著如果可以定制任務就好了，正好我之前也有過一點點網頁爬蟲的經驗，于是著手開始寫，對于這個網頁呢，有很多“不太友好”的地方，比如說：登陸進去之后會啟動新窗口（可能是公司為了信息安全），點擊的控件花樣百出，不易定位，格式不盡相同，有些日期是MM-DD-YYYY，有些是YYYY-MM-DD HH:MM，而且網頁內存在iframe，用傳統的網頁爬蟲無法實現，在參閱了無數資料之后，今天終于開發出來了，現在分享給大家，共同進步。
功能描述：
可以預先按步驟設定任務，完全模擬網頁中的手工操作，對各種控件進行操作，只需輕輕點擊開始，網頁即可自動填表，提交，等待報表在網頁中產生即可。
可以重新獲取IE的控制權，防止新窗口出現后丟失窗口。
可以根據預設參數獲取時間和日期，如：下一個工作日的前一天的23:59:59。
加入“工作日表”，可在里面提前設定“補假”，“加班”等特殊工作日，準確判斷下一工作日。
表設計：
首先是報表列表，用于定位網頁中報表頁面
因為網頁中有多處重復的HTMLname，而且無法用其他方法定位控件，特加入“開始搜索位置”用于控件的查找
然后是控件表，用于定位表單頁面中的控件，還可以根據預先設定的控件類型做不同的動作。
任務表，用于記錄任務基本信息，比較簡單
任務流程表，在窗體中定制的流程將會記錄到這個表中：
下面是窗體部分：
控件詳情和報表詳情窗口，沒什么特殊，可用于快速添加網頁控件信息。
任務詳情窗體，整合了任務創建，流程設置，登陸信息輸入和執行功能
新建任務后，在增加流程按鈕的左邊輸入要操作的控件和要輸入的值類型和值的本身，完成整個任務定制后，保存即可執行，系統將會打開IE窗口并執行相應操作，省去不少時間，還能避免手動輸入出錯。
工作日表，用于記錄工作日和更改工作日
下面是部分SQL查詢：
報表列表查詢
SELECT 報表列表.ID, 報表列表.報表名稱
FROM 報表列表;
更改工作日類型子窗體
用于查找下一個工作日
SELECT 工作日表.*
FROM 工作日表
WHERE (((工作日表.工作日)>=DateAdd("d",-7,Date())))
ORDER BY 工作日表.工作日;
任務流程查詢
用于在任務詳情界面顯示流程
SELECT 任務流程表.任務ID, 任務流程表.流程數, 任務流程表.打開報表, 任務流程表.表ID, [報表列表]![報表名稱] AS表名, 任務流程表.控件ID, [element]![名稱] AS 控件名, 任務流程表.控件值類型, 任務流程表.控件值
FROM (任務流程表 LEFTJOIN 報表列表 ON 任務流程表.表ID = 報表列表.ID) LEFT JOIN element ON 任務流程表.控件ID = element.ID
WHERE (((任務流程表.任務ID)=[Forms]![任務詳情]![ID]));
任務流程轉VBA
與VBA對接，包含了執行任務過程中所需的所有控件數據。
SELECT 任務流程表.ID, 任務流程表.任務ID, 任務流程表.流程數, 任務流程表.打開報表, 報表列表.報表名稱, 報表列表.層級, 報表列表.一級, 報表列表.開始搜索位置, 報表列表.二級, 報表列表.是否使用二級網頁位置, 報表列表.二級網頁位置, 報表列表.三級, 報表列表.四級, element.名稱, element.控件類型, element.值, element.數據類型, element.HTMLname,element.HTMLID, element.時間類型, 任務流程表.控件值類型, 任務流程表.控件值
FROM (任務流程表 LEFTJOIN 報表列表 ON 任務流程表.表ID = 報表列表.ID) LEFT JOIN element ON 任務流程表.控件ID = element.ID;
下面是VBA代碼部分
更改工作日類型
'批量修改工作日
Private Sub Command20_Click()
Dim STemp2 As String
Dim i
If IsNull(Me.Text0) Then
MsgBox ("請輸入開始日期！")
Exit Sub
ElseIf IsNull(Me.Text4) Then
MsgBox ("請輸入結束日期！")
Exit Sub
ElseIf IsNull(Me.List40) Then
MsgBox ("請選擇更改類型！")
Else
Dim Rs2 As ADODB.Recordset
Set Rs2 = New ADODB.Recordset
STemp2 = "select * From 工作日表 where 工作日 between #" & Me![Text0]& "# and #" & Me![Text4] & "#"
Rs2.Open STemp2, CurrentProject.Connection,adOpenKeyset, adLockOptimistic
For i = 1 To Rs2.RecordCount
Rs2("類型") = Me![List40]
Rs2.Update
Rs2.MoveNext
Next
Me.Refresh
MsgBox ("成功將"& i - 1 & "天更改為" & Me![List40])
Exit Sub
End If
Exit Sub
Rs2.Close
Set Rs2 = Nothing
End Sub
自動登錄并獲取網頁
用于對付窗口彈出問題
Private Sub Command268_Click()
'On Error Resume Next
'定義變量
Dim IE As Object
Dim webs, webs2, webs3, webs4, webs5, dmt,dmt1, dmt2, usrno, elements, element1, xxx
Dim vtag '網頁對象
Dim loop1, loop2, loop3 '循環計數器
Dim objIE As Object, myHWND
Dim dWinFolder As New ShellWindows, t
Dim Czpmxurl As String, Czpmxname As String
Dim Czpmxhwnd As Long, aa '窗口句柄
Dim cifno$, cifcname$, ResultLink$
'text9 = 用戶名 text11= 密碼
'IE清除緩存&打開登錄界面
Call DeleteCacheURLList
Set IE =CreateObject("InternetExplorer.Application")
IE.Navigate"example.com"
IE.Visible = True '若=0 False不顯示 ,=1 True 顯示
IE.Silent = True
Do While IE.Busy Or IE.ReadyState <>4
DoEvents
Loop
delay Me.Combo17
Set dmt = IE.Document
IE.Document.getElementById("j_username").Value= Me.Text9
IE.Document.getElementById("j_password").Value= Me.Text11
delay 2
IE.Document.getElementById("j_password").focus
SendKeys "{enter}"
Do While IE.Busy Or IE.ReadyState <>4
DoEvents
Loop
delay Me.Combo17 + 3
Czpmxhwnd = FindWindow(vbNullString, "來自網頁的消息") '根據窗口標題查找，找到后返回句柄
If Czpmxhwnd <> 0 Then
aa = SetForegroundWindow(Czpmxhwnd) '將網頁調到前臺
delay 1
SendKeys "{ENTER}", True
End If
delay 1
Call Command271_Click
End Sub
任務執行
根據設定的任務，按流程對網頁中控件進行操作
Private Sub Command271_Click()
'定義變量
Dim IE As Object
Dim webs, webs2, webs3, webs4, webs5, dmt,dmt1, dmt2, dmt3, dmt4, usrno, elements, element1, xxx, departmentNoHTML
Dim vtag, worktype '網頁對象
Dim loop1, loop2, loop3, loop4 '循環計數器 1=網頁對象查找，2= ，3=工作日確定，4=流程進行
Dim objIE As Object, myHWND
Dim dWinFolder As New ShellWindows, t
Dim Czpmxurl As String, Czpmxname As String
Dim Czpmxhwnd As Long, aa '窗口句柄
Dim cifno$, cifcname$, ResultLink$
Dim today0 '今天零點
Dim monthday10000 '當月零點
Dim nworkday '下一工作日
Dim nworkdaypday2359 '下一工作日前一天23點59分
Dim nworkday7 '下一工作日7點
Dim STemp3, STemp4 As String
Dim Rs3 As ADODB.Recordset
Dim Rs4 As ADODB.Recordset
Set Rs3 = New ADODB.Recordset
Set Rs4 = New ADODB.Recordset
workdaytype = "正常"
today0 = Format(Date & "00:00:00", "YYYY/MM/DD HH:MM:SS")
monthday10000 = Format(DateSerial(Year(Date),Month(Date), 1) & " 00:00:00", "YYYY/MM/DD HH:MM:SS")
STemp3 = "select * From 工作日表 where 類型 = " & "'" &workdaytype & "'" & "order by 工作日"
Rs3.Open STemp3, CurrentProject.Connection,adOpenKeyset, adLockOptimistic
For loop3 = 0 To Rs3.RecordCount
If DateDiff("d", Date, Rs3("工作日"))> 0 Then
nworkday = Rs3("工作日")
Exit For
ElseIf loop3 = Rs3.RecordCount Then
MsgBox ("請更新工作日表！")
Exit Sub
Exit For
Else
Rs3.MoveNext
End If
Next
nworkdaypday2359 =Format(DateAdd("d", -1, nworkday) & " 23:59:59","YYYY/MM/DD HH:MM:SS")
nworkday7 = Format(nworkday & "07:00:00", "YYYY/MM/DD HH:MM:SS")
Do
For Each objIE In dWinFolder
If InStr(1, objIE.LocationURL, "elis-lcs.paic") > 0 Then
Czpmxname =objIE.LocationName '標題
Czpmxurl =objIE.LocationURL '鏈接
Exit Do '通過鏈接objIE.LocationURL包含的關鍵字查詢，或用objIE.LocationName即窗口標題包含的關鍵字來查詢
End If
Next
DoEvents
Loop
Set IE = objIE '轉換ie窗口控制權
Do Until IE.ReadyState = 4 And IE.Busy = False
DoEvents
Loop
Set dmt = IE.Document
STemp4 = "select * From 任務流程轉VBA where 任務ID = " & Me![任務ID] & " order by 流程數"
Rs4.Open STemp4, CurrentProject.Connection,adOpenKeyset, adLockOptimistic
For loop4 = 0 To Rs4.RecordCount - 1
If Rs4("打開報表") = True Then
繼續:
Set elements = dmt.all.tags("a")
Debug.Print IE.ReadyState
For loop1 = 0 To elements.length - 1
If elements.Item(loop1).innerText = Rs4("一級")Then
elements.Item(loop1).Click
Exit For
End If
Next
'特殊重名控件
For loop1 = Rs4("開始搜索位置") Toelements.length - 1
Ifelements.Item(loop1).innerText = Rs4("二級")Then
elements.Item(loop1).FireEvent ("onmouseover")
Exit For
End If
Next
delay 0.5
If Rs4("層級") = 3 Then
Set elements = dmt.all.tags("a")
Debug.Print IE.ReadyState
For loop1 = 0 To elements.length - 1
If elements.Item(loop1).innerText = Rs4("三級")Then
elements.Item(loop1).Click
Exit For
End If
Next
ElseIf Rs4("層級") = 4 Then
Set elements = dmt.all.tags("a")
Debug.Print IE.ReadyState
For loop1 = 0 To elements.length - 1
Ifelements.Item(loop1).innerText = Rs4("三級")Then
elements.Item(loop1).FireEvent ("onmouseover")
Exit For
End If
Next
For loop1 = 0 To elements.length - 1
If elements.Item(loop1).innerText =Rs4("四級") Then
elements.Item(loop1).Click
Exit For
End If
Next
delay 1
Else
MsgBox ("請在報表列表中添加報表層級！！！")
Exit Sub
End If
delay 5
GoTo 報表操作
Else '打開報表——結束
網頁表單填寫操作:
Set dmt1 = IE.Document.frames(1).Document 'getElementsByTagName("INPUT")(0)
Set elements = dmt1.all.tags("INPUT") 'Or "SELECT"
If Rs4("控件類型") = "文本框" Then
For loop1 = 0 To elements.length - 1
If IsNull(Rs4("HTMLname")) = False Then
If elements.Item(loop1).Name =Rs4("HTMLname") Then
ID匹配:
Select Case Rs4("控件值類型")
Case "預先制定值"
elements.Item(loop1).Value = Rs4("控件值")
Case "當時"
elements.Item(loop1).Value = Format(Date & " " & Time(),Rs4("時間類型"))
Case "手動輸入"
elements.Item(loop1).Value = InputBox("請輸入"& Rs4("報表名稱") & "中" & Rs4("名稱") &"的值：(" & Rs4("時間類型") & ")", "請輸入")
Case "當月0點"
elements.Item(loop1).Value= Format(monthday10000, Rs4("時間類型"))
Case "今天0點"
elements.Item(loop1).Value = Format(today0, Rs4("時間類型"))
Case "下一工作日前一天23點59分"
elements.Item(loop1).Value= Format(nworkdaypday2359, Rs4("時間類型"))
Case "下一工作日7點"
elements.Item(loop1).Value = Format(nworkday7, Rs4("時間類型"))
Case "本月份"
elements.Item(loop1).Value = Format(Date, Rs4("時間類型"))
End Select
Exit For
End If
Else
If elements.Item(loop1).ID =Rs4("HTMLID") Then
GoTo ID匹配
End If
End If
Next
ElseIf Rs4("控件類型") = "復選框" Then
For loop1 = 0 To elements.length - 1
If elements.Item(loop1).Value =Rs4("值") Then
elements.Item(loop1).Click
Exit For
End If
Next
ElseIf Rs4("控件類型") = "單選框" Then
For loop1 = 0 To elements.length - 1
If elements.Item(loop1).Name =Rs4("HTMLname") Then
elements.Item(loop1).Click
Exit For
End If
Next
ElseIf Rs4("控件類型") = "按鈕" Then
For loop1 = 0 To elements.length - 1
If elements.Item(loop1).Value =Rs4("值") Then
elements.Item(loop1).FireEvent ("onclick")
delay 2
Exit For
End If
Next
ElseIf Rs4("控件類型") = "下拉框" Then
Set elements = dmt1.all.tags("select")
For loop1 = 0 To elements.length - 1
If IsNull(Rs4("HTMLname"))= False Then
Ifelements.Item(loop1).Name = Rs4("HTMLname") Then
ID匹配2:
elements.Item(loop1).Value = Rs4("控件值")
Exit For
End If
Else
If elements.Item(loop1).ID= Rs4("HTMLID") Then
GoTo ID匹配2
End If
End If
Next
End If
Rs4.MoveNext
End If
下一步:
Next
Me.Refresh
Exit Sub
Rs3.Close
Rs4.Close
Set Rs3 = Nothing
Set Rs4 = Nothing
End Sub
任務控件添加
用于在任務詳情界面中添加需要操作的控件。
Private Sub Command45_Click()
Dim STemp As String
Dim Rs As ADODB.Recordset
Set Rs = New ADODB.Recordset
STemp = "select * From 任務流程表 where 任務ID = " & Me![任務ID]
Rs.Open STemp, CurrentProject.Connection,adOpenKeyset, adLockOptimistic
Rs.AddNew
Rs("任務ID")= Me![任務ID]
Rs("流程數")= Rs.RecordCount + 1
Rs("表ID")= Me.Combo60
Rs("表名")= Me.Combo60.Column(1)
Rs("控件ID")= Me.Combo66
Rs("控件名")= Me.Combo66.Column(1)
Rs("控件值類型")= Me.Combo100
Rs("控件值")= Text76
Rs("打開報表")= Me.Check319
Rs.Update
Me.Refresh
Exit Sub
Rs.Close
Set Rs = Nothing
End Sub
尋找已打開IE
Declare Function FindWindow Lib"user32" Alias "FindWindowA" (ByVal lpClassName As String,ByVal lpWindowName As String) As Long
Declare Function SetForegroundWindow Lib"user32" (ByVal HWnd As Long) As Long
窗口尋找
Private Const ERROR_CACHE_FIND_FAIL As Long= 0
Private Const ERROR_CACHE_FIND_SUCCESS AsLong = 1
Private Const ERROR_FILE_NOT_FOUND As Long= 2
Private Const ERROR_ACCESS_DENIED As Long =5
Private Const ERROR_INSUFFICIENT_BUFFER AsLong = 122
Private Const MAX_PATH As Long = 260
Private Const MAX_CACHE_ENTRY_INFO_SIZE AsLong = 4096
Private Const LMEM_FIXED As Long = &H0
Private Const LMEM_ZEROINIT As Long =&H40
Private Const LPTR As Long = (LMEM_FIXED OrLMEM_ZEROINIT)
Private Const NORMAL_CACHE_ENTRY As Long =&H1
Private Const EDITED_CACHE_ENTRY As Long =&H8
Private Const TRACK_OFFLINE_CACHE_ENTRY AsLong = &H10
Private Const TRACK_ONLINE_CACHE_ENTRY AsLong = &H20
Private Const STICKY_CACHE_ENTRY As Long =&H40
Private Const SPARSE_CACHE_ENTRY As Long =&H10000
Private Const COOKIE_CACHE_ENTRY As Long =&H100000
Private Const URLHISTORY_CACHE_ENTRY AsLong = &H200000
Private Const URLCACHE_FIND_DEFAULT_FILTER AsLong = NORMAL_CACHE_ENTRY Or _
COOKIE_CACHE_ENTRY Or _
URLHISTORY_CACHE_ENTRY Or _
TRACK_OFFLINE_CACHE_ENTRY Or _
TRACK_ONLINE_CACHE_ENTRY Or _
STICKY_CACHE_ENTRY
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type INTERNET_CACHE_ENTRY_INFO
dwStructSize As Long
lpszSourceUrlName As Long
lpszLocalFileName As Long
CacheEntryType As Long
dwUseCount As Long
dwHitRate As Long
dwSizeLow As Long
dwSizeHigh As Long
LastModifiedTime As FILETIME
ExpireTime As FILETIME
LastAccessTime As FILETIME
LastSyncTime As FILETIME
lpHeaderInfo As Long
dwHeaderInfoSize As Long
lpszFileExtension As Long
dwExemptDelta As Long
End Type
Private Declare FunctionFindFirstUrlCacheEntry Lib "wininet" Alias"FindFirstUrlCacheEntryA" (ByVal lpszUrlSearchPattern As String,lpFirstCacheEntryInfo As Any, lpdwFirstCacheEntryInfoBufferSize As Long) AsLong
Private Declare FunctionFindNextUrlCacheEntry Lib "wininet" Alias "FindNextUrlCacheEntryA"(ByVal hEnumHandle As Long, lpNextCacheEntryInfo As Any,lpdwNextCacheEntryInfoBufferSize As Long) As Long
Private Declare Function FindCloseUrlCacheLib "wininet" (ByVal hEnumHandle As Long) As Long
Private Declare FunctionDeleteUrlCacheEntry Lib "wininet" Alias"DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
Private Declare Sub CopyMemory Lib"kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource AsAny, ByVal dwLength As Long)
Private Declare Function lstrcpyA Lib"kernel32" (ByVal RetVal As String, ByVal Ptr As Long) As Long
Private Declare Function lstrlenA Lib"kernel32" (ByVal Ptr As Any) As Long
Private Declare Function LocalAlloc Lib"kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long
Private Declare Function LocalFree Lib"kernel32" (ByVal hMem As Long) As Long
Public Sub DeleteCacheURLList()
Dim icei As INTERNET_CACHE_ENTRY_INFO
Dim hFile As Long
Dim cachefile As String
Dim posUrl As Long
Dim posEnd As Long
Dim dwBuffer As Long
Dim pntrICE As Long
hFile = FindFirstUrlCacheEntry(0&, ByVal 0, dwBuffer)
If(hFile = ERROR_CACHE_FIND_FAIL) And _
(Err.LastDllError = ERROR_INSUFFICIENT_BUFFER) Then
pntrICE = LocalAlloc(LMEM_FIXED, dwBuffer)
If pntrICE <> 0 Then
CopyMemory ByVal pntrICE, dwBuffer, 4
hFile = FindFirstUrlCacheEntry(vbNullString, _
ByValpntrICE, _
dwBuffer)
If hFile <> ERROR_CACHE_FIND_FAIL Then
Do
CopyMemory icei, ByVal pntrICE,Len(icei)
If (icei.CacheEntryType And _
NORMAL_CACHE_ENTRY) =NORMAL_CACHE_ENTRY Then
cachefile =GetStrFromPtrA(icei.lpszSourceUrlName)
Call DeleteUrlCacheEntry(cachefile)
End If
Call LocalFree(pntrICE)
dwBuffer = 0
CallFindNextUrlCacheEntry(hFile, ByVal 0, dwBuffer)
'allocate and assign the memoryto the pointer
pntrICE =LocalAlloc(LMEM_FIXED, dwBuffer)
CopyMemory ByVal pntrICE,dwBuffer, 4
DoEvents
Loop While FindNextUrlCacheEntry(hFile, ByVal pntrICE, dwBuffer)
End If 'hFile
End If 'pntrICE
End If 'hFile
Call LocalFree(pntrICE)
Call FindCloseUrlCache(hFile)
End Sub
Private Function GetStrFromPtrA(ByVal lpszAAs Long) As String
GetStrFromPtrA = String$(lstrlenA(ByVal lpszA), 0)
Call lstrcpyA(ByVal GetStrFromPtrA, ByVal lpszA)
End Function
————————————————
版權聲明：本文為CSDN博主「Antonio·Future」的原創文章，遵循CC 4.0 BY-SA版權協議，轉載請附上原文出處鏈接及本聲明。
原文鏈接：https://blog.csdn.net/qq_15041159/article/details/79949997
