Microsoft Internet Controls Microsoft Html Object Library
即可，然後在窗體上加入 “Microsoft Web 浏覽器”控件
好了，下面就以我寫的一個讀取某 IP 物理地域查詢網站頁面的數據庫為例說明 DHtml / “Microsoft Web 浏覽器”控件在 Access 的應用吧。
“Microsoft Web 浏覽器”控件的作用是什麼哪？主要就是為了獲得 DOCUMENT 對象的，DHtml 的操作都是以 DOCUMENT 對象為運行基礎的。
要完成讀取網頁的功能我們必須了解 DHtml 的幾個簡單的對象以及屬性 1、DOCUMENT 對象：代表這整個 Html 文檔 2、BODY 對象：是 DOCUMENT 對象的子對象，裡面存儲著所有顯示給用戶看的 Html 代碼 3、innerText 屬性：頁面中顯示給客戶看的文本，注意：不是 Html 代碼呦 4、innerHTML屬性：構成頁面的 Html 代碼 5、對象.all.length屬性：頁面中所有 element 的個數。（all 用於表示所有對象）
ok ，接下來就讓我們一邊寫代碼，一邊分析吧： Option Compare Database Dim blnSwitch As Boolean Private Sub Command1_Click() '用於啟動浏覽功能 Me.WebBrowser3.Navigate ("http://ip.loveroot.com/index.PHP?job=search") End Sub
Private Sub Command11_Click() '將需要搜索的IP 寫入全局變量 splitIP Text1.Value End Sub Function splitIP(strip) '將需要搜索的IP 寫入全局變量 Dim a() As String strip = strip & "." a = Split(strip, ".")
Dim i As Long For i = 0 To UBound(a) If a(i) = "" Then a(i) = "0" lngSearchIP(4 - i) = CLng(a(i)) Next i
End Function
Sub WriteLog(ip1 As String) '讀取結果 Dim dc As MSHTML.HtmlDocument Dim Bd As MSHTML.HtmlBody Dim El As MSHTML.HtmlElementCollection Dim strip As String Dim strAdd As String Dim strSql Dim i As Long Set dc = WebBrowser3.Document Set Bd = dc.body
Dim lngStart As Long
'循環 DOCUMENT 中所有的元素獲取需要的字符 For i = 0 To dc.all.length - 1 '由於該服務器重寫界面，我改了一下分析代碼 'If dc.all(i).tagName = "p" And Left(dc.all(i).innerText, 4) = "查詢結果" Then If dc.all(i).tagName = "p" And Left(dc.all(i).innerText, 8) = "官方數據查詢結果" Then '由於該服務器重寫界面，我改了一下分析代碼 'strAdd = Mid(dc.all(i).innerText, InStr(1, dc.all(i).innerText, "(") + 2, InStr(1, dc.all(i).innerText, ")") - InStr(1, dc.all(i).innerText, "(") - 3) 'strip = Mid(dc.all(i).innerText, InStr(1, dc.all(i).innerText, "查詢結果：") + 6, InStr(1, dc.all(i).innerText, "(") - InStr(1, dc.all(i).innerText, "查詢結果：") - 7) strAdd = Right(dc.all(i).innerText, Len(dc.all(i).innerText) - InStr(dc.all(i).innerText, " - ") - 3) strip = strNowIP LabelSIP.Caption = strip & strAdd 'ok 終於得到需要的數據了，用 SQL 語句直接寫入數據庫吧 strSql = "update ipaddress set [ip1]='" & strip & "',[add]='" & strAdd & "' where mark='last'" CurrentProject.Connection.Execute strSql strSql = "insert into ipaddress([ip1],[add],[mark],[enip]) values('" & strip & "','" & strAdd & "','no'," & CStr(enaddr(strip)) & ")" CurrentProject.Connection.Execute strSql Exit For End If Next i
Dim strNewIP As String strNewIP = refreshIP On Error Resume Next '利用 DHtml 的 innerHtml 來更改網頁的源代碼，建立一個簡單的 FORM ，然後提交給服務器，繼續查詢下面的 IP Bd.innerHtml = "<form method='POST' action='index.PHP?job=search' target='_parent'><input type='text' name='search_ip' ><input type='submit' value='查詢' name='B1'></form>" '在 INPUT TEXT search_ip 中填入 IP。 dc.all.Item("search_ip").Value = strNewIP '用 DHtml 提交 FORM 到服務器 dc.all.Item("b1").Click End Sub
Private Sub Form_Open(Cancel As Integer) Text1.Value = Nz(DLookup("ip1", "ipaddress", "[mark]='last" & Me.Caption & "'"), "1.0.0.0")
End Sub
Private Sub WebBrowser3_DownloadComplete() '該事件在頁面成功下載到本地時運行，這時候 DOCUMENT 對象 '已經完全被客戶端浏覽器讀取了，我們只要獲取 Body 對象中的 innerHtml 即可 If Len(strNowIP) = 0 Then splitIP Text1.Value End If
If check1.Value = True Then Call WriteLog("61.12.15.117") End If End Sub
Function refreshIP() As String '搜索完一個IP以後再搜索下面一個 Dim i As Long lngSearchIP(2) = lngSearchIP(2) + 1 For i = 2 To 4 If lngSearchIP(i) >= 256 Then lngSearchIP(i) = 0 lngSearchIP(i + 1) = lngSearchIP(i + 1) + 1 End If Next i refreshIP = Format(lngSearchIP(4), "0") & "." & Format(lngSearchIP(3), "0") & "." & Format(lngSearchIP(2), "0") & "." & Format(lngSearchIP(1), "0") strNowIP = refreshIP Debug.Print refreshIP End Function
以下代碼請新建一個模塊後 COPY 進去 Option Compare Database Public lngSearchIP(4) As Long Public strNowIP As String Public strOKAddress As String Public strOKIP As String Public blnStop As Boolean Function writeOKIP() Dim rs As New ADODB.Recordset Dim strSql As String
strSql = "select * from ipaddress order by enip" rs.Open strSql, CurrentProject.Connection, 1, 1
Dim strAdd1 As String Dim strIP1 As String Dim lngENIP1 As Long Dim strState As String strState = "start"
Dim i As Long Dim iA As Long iA = rs.RecordCount
Do Until rs.EOF If blnStop = True Then Exit Function If strAdd1 <> rs("add") Then strSql = "update ipaddress_ok set ip2='" & strIP1 & " ',enip2=" & Str(lngENIP1) & ",mark='' where mark='setting'" CurrentProject.Connection.Execute strSql DoEvents strSql = "insert into ipaddress_ok (ip1,enip1,[mark],[add]) values('" & rs("ip1") & "'," & Str(rs("enip")) & ",'setting','" & rs("add") & "')" CurrentProject.Connection.Execute strSql DoEvents End If
strAdd1 = rs("add") strIP1 = rs("ip1") lngENIP1 = rs("enip") i = i + 1 Form_控制.Label4.Caption = Str(Int(i / iA * 10000) / 100) & "%" rs.MoveNext Loop rs.Close
strSql = "update ipaddress_ok set ip2=mid(ip2,1,len(ip2)-2) & '255'" CurrentProject.Connection.Execute strSql strSql = "update ipaddress_ok set enip1=enaddr(ip1)" CurrentProject.Connection.Execute strSql strSql = "update ipaddress_ok set enip2=enaddr(ip2)" CurrentProject.Connection.Execute strSql End Function
Function enaddr(Sip As String) As Double '用代理無法連接的問題還要解決 '將字符的 IP 編碼為長整的 IP On Error Resume Next Dim str1 As String Dim str2 As String Dim str3 As String Dim str4 As String Sip = CStr(Sip) str1 = Left(Sip, CInt(InStr(Sip, ".") - 1)) Sip = Mid(Sip, CInt(InStr(Sip, ".")) + 1) str2 = Left(Sip, CInt(InStr(Sip, ".")) - 1) Sip = Mid(Sip, CInt(InStr(Sip, ".")) + 1) str3 = Left(Sip, CInt(InStr(Sip, ".")) - 1) str4 = Mid(Sip, CInt(InStr(Sip, ".")) + 1) enaddr = CLng(str1) * 256 * 256 * 256 + CLng(str2) * 256 * 256 + CLng(str3) * 256 + CLng(str4) - 1 End Function
