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

启航图

我想把百度地图搜索结果导出文件，例如：百度地图里搜索“餐饮”，区域是全北京地区，要“名称”“电话”“省份”“城市”“地址”“经度/纬度”，怎么把搜索的结果直接导成文件，望大神指导

启航图

1. Sub BaiDuMap()
   
2. Dim winhttp, URL, arr, i, j, p, t, objSC, strJSON, objJSON, pages, n, strFunc, jsonItem
   
3. Sheet1.Cells.Clear
   
4. Set winhttp = CreateObject("WinHttp.WinHttpRequest.5.1")
   
5. Application.ScreenUpdating = False
   
6. Application.DisplayStatusBar = True
   
7. With winhttp
   
8. For i = 1 To 94
   
9. URL = "http://map.baidu.com/?newmap=1&reqflag=pcmap&biz=1&pcevaname=pc2&da_par=baidu&from=webmap&qt=con&from=webmap&c=179&wd=%E6%AF%8D%E5%A9%B4%E5%BA%97&pn=" & i - 1 & "&db=0&wd2=&sug=0&da_src=pcmappg.poi.page&on_gel=1&src=7&gr=3&b=(13333343.77,3501052.46;13433759.77,3528380.46)&l=12&addr=0&nn=" & (i - 1) * 10 & "&tn=B_NORMAL_MAP&ie=utf-8&t=1423980798053"
   
10. .Open "GET", URL, False
    
11. .setRequestHeader "Connection", "Keep-Alive"
    
12. .send
    
13. t = UToGB(.responsetext)
    
14. strJSON = Split(Split(t, """content"":")(1), ",""current_city")(0)
    
15. Set objSC = CreateObject("ScriptControl")
    
16. objSC.Language = "JScript"
    
17. strFunc = "function getjson(s) { return eval('(' + s + ')'); }"
    
18. objSC.AddCode strFunc
    
19. Set objJSON = objSC.CodeObject.getjson(strJSON)
    
20. For Each jsonItem In objJSON
    
21. On Error Resume Next
    
22. n = n + 1
    
23. Cells(n, 1) = CallByName(jsonItem, "name", VbGet)
    
24. Cells(n, 2) = CallByName(jsonItem, "addr", VbGet)
    
25. Cells(n, 3) = CallByName(jsonItem, "tel", VbGet)
    
26. Next
    
27. 
    
28. Next
    
29. End With
    
30. Set objSC = Nothing
    
31. Set objJSON = Nothing
    
32. Set jsonItem = Nothing
    
33. Set winhttp = Nothing
    
34. Application.StatusBar = False
    
35. Application.ScreenUpdating = True
    
36. End Sub
    
37. Function UToGB(ByVal str1 As String)
    
38. Dim i, y, arr1(), arr2(), ireg As Object, imch As Object, mch As Object
    
39. Set ireg = CreateObject("vbscript.regexp")
    
40. ireg.Global = True
    
41. ireg.Pattern = "\\u\w{4}"
    
42. Set imch = ireg.Execute(str1)
    
43. For Each mch In imch
    
44. y = y + 1
    
45. ReDim Preserve arr1(1 To y)
    
46. ReDim Preserve arr2(1 To y)
    
47. arr1(y) = ChrW(CLng(Replace(mch.Value, "\u", "&h")))
    
48. arr2(y) = mch.Value
    
49. Next
    
50. For i = 1 To UBound(arr1)
    
51. str1 = Replace(str1, arr2(i), arr1(i))
    
52. Next
    
53. UToGB = str1
    
54. Set ireg = Nothing
    
55. End Function

复制代码

这些代码不能导出经纬度

nishuodebai

期待有大神来解决。

YZC51

经纬度
Cells(n + 1, 6) = CallByName(jsonItem, "diPointX", VbGet) & "/" & CallByName(jsonItem, "diPointY", VbGet)

启航图

YZC51 发表于 2015-12-6 09:55
经纬度
Cells(n + 1, 6) = CallByName(jsonItem, "diPointX", VbGet) & "/" & CallByName(jsonItem, "diPo ...

是这样吗大神，但导出的结果不是经纬度啊

1. Sub BaiDuMap()
   
2. Dim winhttp, URL, arr, i, j, p, t, objSC, strJSON, objJSON, pages, n, strFunc, jsonItem
   
3. Sheet1.Cells.Clear
   
4. Set winhttp = CreateObject("WinHttp.WinHttpRequest.5.1")
   
5. Application.ScreenUpdating = False
   
6. Application.DisplayStatusBar = True
   
7. With winhttp
   
8. For i = 1 To 10
   
9. URL = "http://map.baidu.com/?newmap=1&reqflag=pcmap&biz=1&pcevaname=pc2&da_par=baidu&from=webmap&qt=con&from=webmap&c=179&wd=%E6%AF%8D%E5%A9%B4%E5%BA%97&pn=" & i - 1 & "&db=0&wd2=&sug=0&da_src=pcmappg.poi.page&on_gel=1&src=7&gr=3&b=(13333343.77,3501052.46;13433759.77,3528380.46)&l=12&addr=0&nn=" & (i - 1) * 10 & "&tn=B_NORMAL_MAP&ie=utf-8&t=1423980798053"
   
10. .Open "GET", URL, False
    
11. .setRequestHeader "Connection", "Keep-Alive"
    
12. .send
    
13. t = UToGB(.responsetext)
    
14. strJSON = Split(Split(t, """content"":")(1), ",""current_city")(0)
    
15. Set objSC = CreateObject("ScriptControl")
    
16. objSC.Language = "JScript"
    
17. strFunc = "function getjson(s) { return eval('(' + s + ')'); }"
    
18. objSC.AddCode strFunc
    
19. Set objJSON = objSC.CodeObject.getjson(strJSON)
    
20. For Each jsonItem In objJSON
    
21. On Error Resume Next
    
22. n = n + 1
    
23. Cells(n, 1) = CallByName(jsonItem, "name", VbGet)
    
24. Cells(n, 2) = CallByName(jsonItem, "addr", VbGet)
    
25. Cells(n, 3) = CallByName(jsonItem, "tel", VbGet)
    
26. Cells(n, 6) = CallByName(jsonItem, "diPointX", VbGet) & "/" & CallByName(jsonItem, "diPointY", VbGet)
    
27. Next
    
28. 
    
29. Next
    
30. End With
    
31. Set objSC = Nothing
    
32. Set objJSON = Nothing
    
33. Set jsonItem = Nothing
    
34. Set winhttp = Nothing
    
35. Application.StatusBar = False
    
36. Application.ScreenUpdating = True
    
37. End Sub
    
38. Function UToGB(ByVal str1 As String)
    
39. Dim i, y, arr1(), arr2(), ireg As Object, imch As Object, mch As Object
    
40. Set ireg = CreateObject("vbscript.regexp")
    
41. ireg.Global = True
    
42. ireg.Pattern = "\\u\w{4}"
    
43. Set imch = ireg.Execute(str1)
    
44. For Each mch In imch
    
45. y = y + 1
    
46. ReDim Preserve arr1(1 To y)
    
47. ReDim Preserve arr2(1 To y)
    
48. arr1(y) = ChrW(CLng(Replace(mch.Value, "\u", "&h")))
    
49. arr2(y) = mch.Value
    
50. Next
    
51. For i = 1 To UBound(arr1)
    
52. str1 = Replace(str1, arr2(i), arr1(i))
    
53. Next
    
54. UToGB = str1
    
55. Set ireg = Nothing
    
56. End Function
    

复制代码

YZC51

传附件看看!```

启航图

YZC51 发表于 2015-12-6 15:36
传附件看看!```

请大神过目

YZC51

这样呢？Cells(n, 4) = CallByName(jsonItem, "diPointX", VbGet) / 10000000 & "/" & CallByName(jsonItem, "diPointY", VbGet) / 10000000

gisman117544110

楼主的采集字段 和我的查不到。 不过我是在C#里采集的。 原理应该是一样的，只是效率上肯定比excel强大多了！ 晒图：

冰冰99

=(13333343.77,3501052.46;13433759.77,3528380.46) 这个范围是怎么换算的呢