下载百度地图搜索结果

时间 : 15-02-16 栏目 : 网页采集 作者 : 战战如疯 评论 : 0 点击 : 4,046 次

除非注明,文章均为 战战如疯 原创,转载请保留链接: http://www.zhanzhanrufeng.com/cat3/629.html,VBA交流群273624828。

看个网抓的例子。

在百度地图搜索杭州,然后在杭州搜索关键词“母婴店”,现在要将搜索得到的结果提取出来,这里只提取店名,地址和电话。

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=%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"
.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
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

示例文件下载地址: http://pan.baidu.com/s/1i3GJBRR



2017年三月
« 七    
 12345
6789101112
13141516171819
20212223242526
2728293031  

联系博主

咨询,程序开发,友链交换请联系博主 QQ:449217002
VBA QQ群:273624828

注意!复制代码请用Ctrl+C!

相关文章



无觅相关文章插件,快速提升流量

0