会python真的可以为所欲为0(回)
350天前
这里还有人吗1(回)
535天前这里还有人吗0(回)
535天前
每天面对着电脑屏幕，敲打键盘。我所面对的并不只是代码，而是一种生活方式。0(回)
760天前到处都是羊，不想上班0(回)
840天前
鸽子
0(回)
844天前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 |
by: 发表于：2017-10-16 17:22:56 顶(0) | 踩(0) 回复
??
回复评论