【Access小品】一网打尽---从网页快速提取数据

todaynew

　　周末闲来无事，研究了一下WebBrowser控件。很久之前记得红尘同志做过一个天气预报的窗体，前不久海峰同志在解决一个版友的提问时也处理过类似问题。当时感到有些新奇，但没有做深入的研究。最近在做.NET方面的学习，一直觉得用ASP.NET解决网页方面的问题，较之ACCESS来得更为容易一些，便觉得犯不着在Access上折腾与网页有关的问题。今天仔细在网上找了一些与WebBrowser控件有关的资料，觉得可以通过这个控件做一些与网页相关的应用。于是便决定写此例，初步揭示窗体嵌入网页并提取网页数据方面的应用。

　　这个示例以OFFICE中国论坛的Access常规交流版面为数据提取对象，提取论坛的文贴标题及其链接地址。处理这个问题有这么几个要点：

　　１、要在窗体上添加一个WebBrowser控件；

　　２、需要添加两个引用：Microsoft HTML Object Library和Microsoft Internet Controls

　　３、需要用到WebBrowser控件的DocumentComplete事件。注意这个事件在WebBrowser控件属性中是找不到的，可以直接在VBa设计视图下直接书写：Private Sub WebBrowser0_DocumentComplete(ByVal pDisp As Object, URL As Variant)

　　４、对提取的目标网页进行分析找出提取的规律。方法是右击网页，点击“查看源文件”，在打开的源文件代码中找到要提取对象的一些特定的属性，比如class属性或者id属性等。在OFFICE中国论坛的Access常规交流版面的html代码中class设置为“xst”的a标签就是我们要提取的数据。我们只要遍历具有这个特征的a标签，并提取它们的innerText和href就完成任务了。

　　除了这个示例所示的应用外，通过WebBrowser控件及vba代码甚至可以做出编写网页的功能来，所以其应用的方面应该十分广泛，对WebBrowser控件有兴趣的版友可以查看以下地址：http://z.book118.com/009jiaoyuzi ... %C3%BC%BC%C7%C9.htm

Private Sub WebBrowser0_DocumentComplete(ByVal pDisp As Object, URL As Variant)
    Dim doc As IHTMLDocument6
    Dim a_tags As IHTMLElementCollection
    Dim a_tag As HTMLAnchorElement
    Dim txt As String, strhref As String
    Dim ssql As String
    Dim m As Long
    Set doc = Me.WebBrowser0.Document
   
    If InStr(URL, "http://www.office-cn.net/forum-2") > 0 Then
        Set a_tags = doc.all.tags("a")
        m = 0
        For Each a_tag In a_tags
            If a_tag.className = "xst" Then
                txt = a_tag.innerText
                strhref = a_tag.href
                If DCount("*", "文贴表", "标题='" & txt & "'") = 0 Then
                    ssql = "insert into 文贴表 (标题,地址) values ('" & txt & "','" & strhref & "')"
                    CurrentDb.Execute ssql
                    m = m + 1
                End If
            End If
        Next a_tag
        Me.文贴子窗体.Form.Requery
        MsgBox "已自动提取 " & m & " 条记录！"
    End If
End Sub

joelongma

Private Sub Combo1_AfterUpdate()
    Me.WebBrowser0.Navigate Me.Combo1.Column(2)
End Sub
我把这个应用和通用快速开发平台结合了一下，但是这一项，总是会显示错误信息13，这是为什么呢，另外这个navigate 语法是什么意思呀，能把这一句解释一下吗？谢谢了

nncchh

学习学习，谢谢分享！

nncchh

学习学习，谢谢分享！

joshey

代码作以下调整可以正常提取了。
If InStr(URL, "http://www.office-cn.net/forum-2") > 0 Then
网站表第一项修改为http://www.office-cn.net

joshey

为什么不能正常提取呢？

bjcompass

版主好东西真多，再看一遍还有收获，谢谢

软件下载

网站已经改版，我帮你修改了一段代码，现在能正常采集了。
请把下面这段代码替换源代码中的过程

修改处有2个：一是if instr(url...)后面的网址域名有变化。
二是classname多了个“S ”
Private Sub WebBrowser0_DocumentComplete(ByVal pDisp As Object, URL As Variant)

    Dim doc As IHTMLDocument6
    Dim a_tags As IHTMLElementCollection
    Dim a_tag As HTMLAnchorElement
    Dim txt As String, strhref As String
    Dim ssql As String
    Dim m As Long
    Me.Text9 = WebBrowser0.LocationURL
    Set doc = Me.WebBrowser0.Document
    If InStr(URL, "http://www.office-cn.net/forum-2-1") > 0 Then
   ' MsgBox URL
        Set a_tags = doc.all.tags("a")
        m = 0
      '  Debug.Print a_tags
        For Each a_tag In a_tags
            If a_tag.className = "s xst" Then
                txt = a_tag.innerText
                strhref = a_tag.href
                If DCount("*", "文贴表", "标题='" & txt & "'") = 0 Then
                    ssql = "insert into 文贴表 (标题,地址) values ('" & txt & "','" & strhref & "')"
                    CurrentDb.Execute ssql
                    m = m + 1
                End If
            End If
        Next a_tag
        Me.文贴子窗体.Form.Requery
        MsgBox "已自动提取 " & m & " 条记录！"
    End If
End Sub

软件下载

http://z.book118.com/009jiaoyuzi ... %C3%BC%BC%C7%C9.htm已经失效了。

我用excel的webbrowser做了个采集搜房、58和赶集词源的程序，界面难看，代码感觉挺雍肿，来看看你这个

asklove

真是好东西，收藏了