VBA 网页抓取数据进行翻页，单步执行可以，F5运行出错

张文洲

最近在学习网页抓取数据，比如要在百度地图查询  “武汉 公园” 的信息，要对查询结果进行翻页，单步运行代码没有问题，按F5就提示：“对象变量或With模块变量未设置”
请大神们指点迷津

1. Sub LOADIE()   '在代码的常见的处理情况
   
2. Dim i, w, k1, n
   
3. Dim k
   
4. Set iea = CreateObject("InternetExplorer.Application")
   
5. iea.Visible = True
   
6. iea.Navigate "http://map.baidu.com/"  '←打开某个网页，要一定时间，但代码会往下执行
   
7. Do Until iea.ReadyState = 4 '  检查网页是否加载完毕（4表示完全加载）
   
8.    DoEvents                '循环中交回工作权限给系统，以免“软死机”
   
9. Loop
   
10. Set dmt = iea.Document
    
11. dmt.all("PoiSearch").Value = "武汉 公园"
    
12. dmt.all("PoiSearchbtn").Click
    
13. Do Until iea.ReadyState = 4 '  检查网页是否加载完毕（4表示完全加载）
    
14.    DoEvents                '循环中交回工作权限给系统，以免“软死机”
    
15. Loop
    
16. i = 1
    
17. w = 2
    
18. k1 = 0
    
19. Do Until i = w + 0
    
20.     k1 = dmt.all("result_page_c").sourceIndex  '此语句位置出错，单步运行没有问题
    
21.         For n = 1 To 14
    
22.             If dmt.all(k1 + n).tagName = "SPAN" And dmt.all(k1 + n).innerText = "下一页>" Then
    
23.                 m = k1 + n - 1
    
24.                 w = dmt.all(m).innerText + 0
    
25.                 Exit For
    
26.             Else
    
27.             End If
    
28.         Next
    
29.     dmt.all(m + 2).Click
    
30. i = i + 1
    
31. Loop
    
32. End Sub

复制代码

网页数据抓取.rar (13.08 KB, 下载次数: 55)

2014-9-27 15:44 上传

点击文件名下载附件

suwenkai

试一下

1. Sub 按钮1_单击()
   
2.     Dim url, js
   
3.     Set js = CreateObject("scriptcontrol")
   
4.     [a2:b20].ClearContents
   
5.     js.Language = "jscript"
   
6.     For p = 1 To 4
   
7.     url = "http://map.baidu.com/"
   
8.     url = url & "?newmap=1"
   
9.     url = url & "&qt=s"
   
10.     url = url & "&c=218"
    
11.     url = url & "&wd=武汉 公园"
    
12.     url = url & "&nn=" & (p - 1) * 10 '第一页是0，第二页是10，第三页是20，以此类推
    
13.     url = url & "&ie=utf-8"
    
14.     With CreateObject("msxml2.xmlhttp")
    
15.         .Open "get", url, False
    
16.         .send
    
17.         js.addcode ("suwenkai = " & .responsetext)
    
18. 
    
19.         slen = js.eval("suwenkai.content.length") - 1
    
20. 
    
21.         For i = 0 To slen
    
22.             n = n + 1
    
23.             Cells(n + 1, 1) = js.eval("suwenkai.content[" & i & "].name")
    
24.             Cells(n + 1, 2) = js.eval("suwenkai.content[" & i & "].addr")
    
25.         Next
    
26.     End With
    
27.     Next
    
28. End Sub
    

复制代码

张文洲

加了一句延时等待语句和防错语句，就可以顺利运行了。

1. Sub LOADIE()   '在代码的常见的处理情况
   
2. On Error Resume Next
   
3. Set iea = CreateObject("InternetExplorer.Application")
   
4. iea.Visible = True
   
5. iea.Navigate "http://map.baidu.com/"  '←打开某个网页，要一定时间，但代码会往下执行
   
6. Do Until iea.ReadyState = 4 '  检查网页是否加载完毕（4表示完全加载）
   
7.    DoEvents                '循环中交回工作权限给系统，以免“软死机”
   
8. Loop
   
9. Set dmt = iea.Document
   
10. dmt.all("PoiSearch").Value = "武汉 公园"   ' 设置查询参数
    
11. dmt.all("PoiSearchbtn").Click ' 进行查询
    
12. Do Until iea.ReadyState = 4 '  检查网页是否加载完毕（4表示完全加载）
    
13.    DoEvents                '循环中交回工作权限给系统，以免“软死机”
    
14. Loop
    
15. i = 1
    
16. w = 2
    
17. k1 = 0
    
18. Cells.Clear
    
19. For i = 1 To 5000
    
20.     k1 = dmt.all("result_page_c").sourceIndex
    
21.         For n = 1 To 14
    
22.             If dmt.all(k1 + n).tagName = "SPAN" And dmt.all(k1 + n).innerText = "下一页>" Then
    
23.                 m = k1 + n - 1
    
24.                 w = dmt.all(m).innerText + 0
    
25.                 Exit For
    
26.             Else
    
27.             End If
    
28.         Next
    
29.     If i > w Then Exit For
    
30.     dmt.all(m + 2).Click
    
31.     StartTime = Now()
    
32.     Do
    
33.         DoEvents
    
34.     Loop Until CLng(DateDiff("S", StartTime, Now())) > 1    '延时1秒
    
35. Next
    
36. iea.Quit
    
37. End Sub

复制代码

张文洲

suwenkai 发表于 2014-9-27 22:36
试一下

对于大神的代码，只能望尘莫及啊
敬佩之情油然而生

HHAAMM

suwenkai 发表于 2014-9-27 22:36
试一下

1. http://map.baidu.com/?newmap=1&reqflag=pcmap&biz=1&from=webmap&qt=s&from=webmap&c=218&pl_data_type=scope&pl_sub_type=&pl_price_section=0%2C%2B&pl_sort_type=&pl_sort_rule=0&pl_discount2_section=0%2C%2B&pl_groupon_section=0%2C%2B&pl_cater_book_pc_section=0%2C%2B&pl_ticket_book_flag_section=0%2C%2B&pl_movie_book_section=0%2C%2B&pl_business_type=scope&pl_business_id=&pl_activity_gwj_section=0%2C%2B&pl_free_section=0%2C%2B&wd=%E6%AD%A6%E6%B1%89%20%E5%85%AC%E5%9B%AD&pn=1&db=0&wd2=&sug=0&da_src=pcmappg.poi.page&on_gel=1&src=7&gr=3&b=(12704351.65,3541101.7;12747167.65,3571949.7)&l=12&addr=0&nn=10&tn=B_NORMAL_MAP&ie=utf-8&t=1411905878789

复制代码

1. 我看到的url是这么一串，该怎么分析那些是必须的那？？

复制代码

suwenkai

HHAAMM 发表于 2014-9-28 20:17

我也不明白是什么意思，一个一个的试出来的。要的保留，不要的删除。

HHAAMM

suwenkai 发表于 2014-9-28 22:16
我也不明白是什么意思，一个一个的试出来的。要的保留，不要的删除。

哦 谢谢！！

弄着玩，下载的数据我又添加几样，包括那个小图片

武汉 公园(1).rar (11.49 KB, 下载次数: 275)

2014-9-28 22:55 上传

点击文件名下载附件

suwenkai

HHAAMM 发表于 2014-9-28 22:56
哦 谢谢！！

弄着玩，下载的数据我又添加几样，包括那个小图片

版主利害啊。

HHAAMM

suwenkai 发表于 2014-9-28 23:00
版主利害啊。

惭愧！！ 惭愧，我是学习修改了点您的代码

HHAAMM

我会点javascript，但一直没这么样用过scriptcontrol对象，这次学习了！！