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

exceltovba

为什么导出的结果和web端结果顺序不太一致？

exceltovba

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

导出顺序和web端结果不太一致？？

hehex

mark 一下，关注学习

TD2014

大神，我下载了（百度_餐饮.rar）
解压后显示一个excel文档，有一个按钮1，请问这个该怎么操作，才能查到北京所有的餐饮店和地址，麻烦大神看到回复一下，十分感谢！！

TD2014

这个怎么用，能不能说详细点，下载了附件，不会用

VBA万岁

Mark一下。

VBA万岁

37楼的代码似乎还可简化如下：
Sub test()
    Dim url, html, js
    Cells.ClearContents

    Set html = CreateObject("htmlfile")
    Set js = CreateObject("scriptcontrol")
    js.Language = "jscript"
    For p = 1 To 100 '自己自行修改要查找对应的ID
        With CreateObject("msxml2.xmlhttp")
            url = "http://map.baidu.com/?newmap=1"
            url = url & "&qt=s"
            url = url & "&from=webmap"
            url = url & "&pl_data_type=cater"
            url = url & "&c=" & p
            url = url & "&wd=ktv"
            .Open "get", url, False
            .send
            js.addcode ("suwenkai = " & .responsetext)
            n = n + 1
            Cells(n, 1) = js.Eval("suwenkai.current_city.code")
            Cells(n, 2) = js.Eval("suwenkai.current_city.name")
            'Range("d9") = Range("d9") & unescape(.responsetext)
        End With
    Next
End Sub

Function unescape(strTobecoded As String) As String
    With CreateObject("msscriptcontrol.scriptcontrol")
        .Language = "JavaScript"
        unescape = .Eval("unescape('" & strTobecoded & "');")
    End With
End Function

VBA万岁

一直对22楼的附件有个疑问——附件对查询内容只设置了5个选项：餐饮、银行、加油站、超市、KTV，其他（增加选项时）的有些搜索不到如：学校、医院；有的又可以搜索到，如：汽车站、酒店。不知为何？

onlycxb

1. 
   
2. Sub 百度地图搜索()
   
3.     Dim objson As Object, StrJs As String, url As String, p
   
4.     Cells.Clear
   
5.     [a1:c1] = [{"店名","地址","电话"}]
   
6.     Set objson = CreateObject("scriptcontrol")
   
7.     objson.Language = "javascript"
   
8.         For p = 1 To 10
   
9.         url = "http://map.baidu.com/?newmap=1"
   
10.         url = url & "&reqflag=pcmap"
    
11.         url = url & "&biz=1"
    
12.         url = url & "&pcevaname=pc2"
    
13.         url = url & "&da_par=direct"
    
14.         url = url & "&from=webmap"
    
15.         url = url & "&qt=s"
    
16.         url = url & "&from=webmap"
    
17.         url = url & "&c=319,+"
    
18.         url = url & "&wd=餐饮"
    
19.         url = url & "&pn=" & p - 1
    
20.         url = url & "&db=0"
    
21.         url = url & "&sug=0"
    
22.         url = url & "&da_src=pcmappg.poi.page"
    
23.         url = url & "&on_gel=1"
    
24.         url = url & "&src=7"
    
25.         url = url & "&gr=3"
    
26.         url = url & "&l=13"
    
27.         url = url & "&addr=0"
    
28.         url = url & "&nn=" & (p - 1) * 10
    
29.         url = url & "&ie=utf-8"
    
30.         url = url & "&t=1428490938134"
    
31.         With CreateObject("msxml2.xmlhttp")
    
32.             .Open "GET", url, False
    
33.             .send
    
34.          StrJs = "var a=" & .responsetext & ";var s=''; for(x in a.content){ s+=a.content[x].name+'\t'+a.content[x].addr+'\t'+a.content[x].tel+'\r';};"
    
35.             StrJs = objson.Eval(StrJs)
    
36.         End With
    
37.         With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    
38.             .SetText StrJs
    
39.             .PutInClipboard
    
40.         End With
    
41.         With ActiveSheet
    
42.             .Cells(Rows.Count, 1).End(xlUp).Offset(1).Select
    
43.             .Paste
    
44.         End With
    
45.     Next p
    
46. End Sub

复制代码

VBA万岁

第7句应放到33句之后。