怎么把百度地图的搜索结果全部导出到Excel文件(通过百度地图采集公司信息--名

[php]代码库

Sub BaiDuMap()
Dim winhttp, URL, arr, i, j, p, t, objSC, strJSON, objJSON, pages, n, strFunc, jsonItem
Sheet1.Cells.Clear
Set winhttp = CreateObject("WinHttp.WinHttpRequest.5.1")
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
With winhttp
For i = 1 To 94
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=%E5%BB%BA%E6%9D%90%E5%B8%82%E5%9C%BA&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"
.Open "GET", URL, False
.setRequestHeader "Connection", "Keep-Alive"
.send
t = UToGB(.responsetext)
strJSON = Split(Split(t, """content"":")(1), ",""current_city")(0)
Set objSC = CreateObject("ScriptControl")
objSC.Language = "JScript"
strFunc = "function getjson(s) { return eval('(' + s + ')'); }"
objSC.AddCode strFunc
Set objJSON = objSC.CodeObject.getjson(strJSON)
For Each jsonItem In objJSON
    On Error Resume Next
    n = n + 1
    Cells(n, 1) = CallByName(jsonItem, "name", VbGet)
    Cells(n, 2) = CallByName(jsonItem, "addr", VbGet)
    Cells(n, 3) = CallByName(jsonItem, "tel", VbGet)
Next

Next
End With
[a1:c1] = Array("名称", "电话", "地址")
Set objSC = Nothing
Set objJSON = Nothing
Set jsonItem = Nothing
Set winhttp = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Function UToGB(ByVal str1 As String)
    Dim i, y, arr1(), arr2(), ireg As Object, imch As Object, mch As Object
    Set ireg = CreateObject("vbscript.regexp")
    ireg.Global = True
    ireg.Pattern = "\\u\w{4}"
    Set imch = ireg.Execute(str1)
    For Each mch In imch
        y = y + 1
        ReDim Preserve arr1(1 To y)
        ReDim Preserve arr2(1 To y)
        arr1(y) = ChrW(CLng(Replace(mch.Value, "\u", "&h")))
        arr2(y) = mch.Value
    Next
    For i = 1 To UBound(arr1)
        str1 = Replace(str1, arr2(i), arr1(i))
    Next
    UToGB = str1
    Set ireg = Nothing
End Function