VBA网抓规划局规划信息

时间：2023-04-19 03:08:01 | 来源：网站运营

时间：2023-04-19 03:08:01 来源：网站运营

VBA网抓规划局规划信息：有了上次抓取糗事百科网页图片的经验，我们这次来抓取一下杭州市规划局官网规划公示信息，从2009年-2018年公示的所有规划的规划图。




要发车了，各位坐稳。




规划局规划公示页面，一共110页，3800多项。






















点开其中一项以后，会出现项目规划信息及图片。
















咱们的目的就是抓取规划信息中的图片。







一、抓取思路

循环打开110个网页，在每个网页中对单项规划进行循环打开，保存其中的图片。这次需要用到一个网抓利器，fiddler软件。利用fiddler软件抓取网页提交和返回的信息，找到相应参数，用send方法提交申请。




听着太简单了

，一句两句说不清，需要教程的私信我。




二、抓取效果

部分抓取的图片，对于比较大的图片（10m以上），抓取速度会有点慢。






















项目规划信息网址、公示发布日期。
















三、代码部分




这次抓取涉及到动态参数的获取，代码有点多。具有动态参数的网页大多是aspx网页

Sub 下载杭州市规划局规划()
Dim strurl$, i%, n%, arr(), b() As Byte
For i = 1 To 110 '定义提取的页码
strurl = "http://gh.tj.gov.cn/newslist.aspx?id=CK0401"
With CreateObject("MSXML2.XMLHTTP")
'第一次GET，获取动态参数VIEWSTATE和EVENTVALIDATION
.Open "GET", strurl, False
.send
strText = .responseText
VIEWSTATE = encodeURI(CStr(Split(Split(strText, "__VIEWSTATE"" value=""")(1), """ />")(0)))
EVENTVALIDATION = encodeURI(CStr(Split(Split(strText, "__EVENTVALIDATION"" value=""")(1), """ />")(0)))
strText = .responseText
VIEWSTATE = encodeURI(CStr(Split(Split(strText, "__VIEWSTATE"" value=""")(1), """ />")(0)))
EVENTVALIDATION = encodeURI(CStr(Split(Split(strText, "__EVENTVALIDATION"" value=""")(1), """ />")(0)))
'这里的翻页动作是POST提交类型，将取得的动态参数写入需要send发送的参数中。
.Open "POST", strurl, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send "&__EVENTARGUMENT=" & i _
& "&__EVENTTARGET=AspNetPager1" _
& "&__EVENTVALIDATION=" & EVENTVALIDATION _
& "&__VIEWSTATE=" & VIEWSTATE _
& "&__VIEWSTATEGENERATOR=14DD91A0" _
& "&AspNetPager1_input=" & i & "-1" _
& "&HiddenFieldPageFinished=1" _
& "&pkid=CK0401" _
& "&pkid2=3" _
& "&newskindid=CK0401" _
& "&Left1$ddl_cname=CK" _
& "&Left1$tb_search=" _
& "&Left1$rbl_site=title"
strText = .responseText
'正则获取单个规划的网址信息
Open ThisWorkbook.Path & "/图片/1.txt" For Output As #1
Print #1, strText
Close
Set reg = CreateObject("vbscript.regexp")
reg.Global = True
reg.IgnoreCase = True
reg.MultiLine = True
reg.Pattern = "<a href='(news.aspx/?id=/d+)'>(.*?)<//a><//td>/s*<td align=""right"" >(/d+-/d+-/d+)</td>"
n = 0
For Each mat In reg.Execute(strText)
n = n + 1
ReDim Preserve arr(1 To 3, 1 To n)
arr(1, n) = "http://gh.tj.gov.cn/" & mat.SubMatches(0) '正则取出的网址
arr(2, n) = mat.SubMatches(1) '正则取出的单项规划
arr(3, n) = mat.SubMatches(2) '正则取出的规划公示时间
Next mat
brr = Application.Transpose(arr)
rrow = ActiveSheet.Cells(Rows.Count, "a").End(3).Row + 1
ActiveSheet.Range("a" & rrow).Resize(UBound(brr), 3) = brr
'循环打开单个规划网址，保存图形文件
Set xml = CreateObject("MSXML2.XMLHTTP")
For r = 1 To UBound(brr)
xml.Open "GET", brr(r, 1), False
xml.send
Do While xml.ReadyState <> 4
DoEvents
Loop
strr = xml.responseText
reg.Pattern = "//Files//image///d+/.jpg"
If reg.Test(strr) Then '保存网页图片
k = 0
For Each mat In reg.Execute(strr)
Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
k = k + 1
xmlhttp.Open "GET", "http://gh.tj.gov.cn" & mat, False
xmlhttp.send
Do While xmlhttp.ReadyState <> 4
DoEvents
Loop
b = xmlhttp.responseBody
On Error Resume Next '排除文件名过长的图片
Open "C:/图片/" & brr(r, 2) & k & ".jpg" For Binary As #1
Put #1, , b
Close
Next
Else
End If
Next
End With
Next
MsgBox "完成"
End Sub

Function encodeURI(strText As String) As String
With CreateObject("msscriptcontrol.scriptcontrol")
.Language = "JavaScript"
encodeURI = .Eval("encodeURIComponent('" & strText & "');")
End With
End Function

说几个知识点：① encodeURI函数，是我们自己定义的转码函数。

②匹配汉字和数字结合的正则表达式写法为：.*?




四、很粗糙的做一个数据分析（大佬轻喷......）




网抓了这么多数据，没有一些感性上的认识，都白抓取了。

将网抓的数据上传到BDP个人版中，用现在很流行的词云图简单的分析了一下杭州市规划的重点区域，可以看出，杭州市近几年项目公示最多的区域基本都是环城四区。

事实上由于市内六区土地利用的日益饱和，目前杭州市也在重点大力发展环城四区及远郊地区，一些高校和医院等都迁往环城四区。天大，南开新校区都在津南区。
















我的微信公众号：VBA说

(ID:todayvba)

欢迎来玩~

公众号回复"网抓"，获取VBA网抓教程。