怎么把百度地图的搜索结果全部导出到Excel文件

VBA万岁

按钮代码作如下改变可在ListBox2中获取相应链接：
Private Sub CommandButton1_Click()
On Error Resume Next
Dim url, html, js, arr
ReDim arr(0 To Val(TextBox3.Text) * 10, 0 To 3)
ListBox2.Clear
url = ""
Set html = CreateObject("htmlfile")
Set js = CreateObject("scriptcontrol")
js.Language = "jscript"
For p = 1 To Val(TextBox3.Text)
    With CreateObject("msxml2.xmlhttp")
        url = "http://map.baidu.com/?newmap=1"
        url = url & "&reqflag=pcmap"
        url = url & "&biz=1"
        url = url & "&pcevaname=pc2"
        url = url & "&from=webmap"
        url = url & "&qt=s"
        url = url & "&wd=" & TextBox2.Text
        url = url & "&c=" & Split(TextBox1.Text, "|")(1)
        url = url & "&sefrom=1"
        url = url & "&tn=B_NORMAL_MAP"
        url = url & "&nn=" & (p - 1) * 10
        url = url & "&ie=utf-8"
        url = url & "&l=12"
        url = url & "&b=11528083.25,4260714.36;11587283.25,4307434.36"
        url = url & "&t=1428631758687"
        .Open "get", url, False
        .send
        js.addcode ("百度结果 = " & .responsetext)
        If js.Eval("百度结果.content") = False Then
            Exit For
        End If
        slen = js.Eval("百度结果.content.length") - 1
        For i = 0 To slen
            n = n + 1
            For j = 0 To 3
                arr(n - 1, j) = js.Eval("百度结果.content[" & i & "]." & Array("name", "addr", "tel", "ext.detail_info.link[0].url")(j))
            Next j
        Next
    End With
Next
ListBox2.List = arr
End Sub

VBA万岁

同时增加如下代码，以在单击ListBox2时可打开相应链接：
Private Sub ListBox2_Click()
    With CreateObject("internetexplorer.application")
        .Visible = True
        .Navigate ListBox2.List(ListBox2.ListIndex, 3)
        Do Until .ReadyState = 4
            DoEvents
        Loop
    End With
End Sub

VBA万岁

若希望在ListBox2中隐藏链接地址，则可在窗体初始化代码中增加如下一句：
ListBox2.ColumnWidths = ListBox2.Width / 3 & "," & ListBox2.Width / 3 & "," & ListBox2.Width / 3 & ",0"

VBA万岁

PS：在ListBox2的属性中应将其ColumnCount属性设置为4

VBA万岁

aman1516 发表于 2015-4-9 21:01
能否上个“成品”附件，更多的应用测试下，也便于大家学习理解

附件：

百度地图.zip (633.3 KB, 下载次数: 967)

2015-4-11 15:09 上传

点击文件名下载附件

PS：附件增加了“百度测距”的功能。该功能的代码取自如下帖子：

http://club.excelhome.net/thread-1163384-1-1.html

jpj123

suwenkai 发表于 2014-10-4 20:13

这也能做出来 ，超赞!

aman1516

VBA万岁 发表于 2015-4-11 15:12
附件：

每个领域，EXCEL都有超多的实际应用，知其一二或易，要熟练与精强就难了。
好好学习下。

VBA万岁

VBA万岁 发表于 2015-4-11 15:12
附件：

以下附件增加了“谷歌测距”的功能：
百度地图.zip (632.08 KB, 下载次数: 358)

2015-4-12 17:39 上传

点击文件名下载附件

a506049858

VBA万岁 发表于 2015-4-11 15:12
附件：

我点击按钮打开之后，为什么没办法搜索出结果呢？数据页都是空白的

ut01

请教大神，我在工作表版里面搜索出来的只有51条记录，修改哪项代码可以搜索更多？ 代码里面几个For p 我都改到0 To 5000了。请教详细的修改位置？