VBA网抓之自定义EXCEL天气预报函数可查询最近7天的天气

百度不到去谷歌 · 发表于 2017-1-10 08:14

天气预报很多人都做过,我这个版本的一部分代码也来自于网友分享,不同的是我进行升级,做了城市代码自动查询以及7天任意时间组合的参数查询 QQ图片20170110081430.png

视频演示如下
http://excel880.com/blog/archives/979
代码如下

'Option Explicit
'作者百度不到去谷歌 excel880.com 作品2016-01-04
'根据城市名称查询最近7天天气预报
'预报天数为逗号分隔的参数,不写返回今天,直接写0的话是7天全部,其余形式 1-7 写哪几个就返回哪几天
'例如天气预报("武汉", "1,2") 返回今天和明天 2,3返回明天和后天可自由组合
Function 天气预报(城市, Optional 预报天数 = "1")
Dim brr, arr
brr = TQYB(城市)
If 预报天数 = 0 Then 预报天数 = "1,2,3,4,5,6,7"
arr = Split(预报天数, ",")
For i = 0 To UBound(arr)
天气预报 = 天气预报 & vbCrLf & Trim(brr(Val(arr(i)) - 1))
Next
天气预报 = Mid(天气预报, 3)
End Function
Function TQYB(城市) 'g根据城市返回7天结果数组
exstr = String(20, " ")
Set regex = CreateObject("vbscript.regexp")
regex.Global = True
regex.Pattern = "[\u0100-\uffff]"
arr = Split("h1,0,14,p,0,18,p,1,10,i,1,10", ",")
Dim brr
With CreateObject("Microsoft.XMLHTTP")
.Open "GET", CityUrl(城市) & "?r=" & Rnd, True
.send
While .readystate <> 4
DoEvents
Wend
If .Status <> 200 Then
Exit Function
End If
mystr = .responsetext
End With
With CreateObject("htmlfile")
.designmode = "on"
.Open
.writeln mystr
mystr = ""
For Each ul In .getelementsbytagname("ul")
If ul.classname = "t clearfix" Then
For Each li In ul.getelementsbytagname("li")
For N = LBound(arr) To UBound(arr) Step 3
Set t = li.getelementsbytagname(arr(N))
st = t.Item(CInt(arr(N + 1))).innertext
If N + 3 < UBound(arr) Then
mystr = mystr & Left(st & exstr, CInt(arr(N + 2)) - regex.Execute(st).Count)
Else
mystr = mystr & st
End If
Next
mystr = mystr & vbCrLf
Next
End If
Next
End With
brr = Split(mystr, vbCrLf)
TQYB = brr
End Function
Public Function GetBody(ByVal URL$)
Dim ObjXML
On Error Resume Next
Set ObjXML = CreateObject("Microsoft.XMLHTTP")
With ObjXML
.Open "Get", URL, False, "", ""
.setRequestHeader "If-Modified-Since", "0"
.send
GetBody = .responsetext
End With
' = BytesToBstr(GetBody, Coding)
Set ObjXML = Nothing
End Function
Function CityUrl(city)
Dim s
s = GetBody("http://www.cnblogs.com/wf225/p/4090737.html") '天气网城市代码a
CityUrl = regGet(s, "\d+=" & city)
If CityUrl <> "" Then CityUrl = "http://www.weather.com.cn/weather/" & Left(CityUrl, 9) & ".shtml"
End Function
Public Function regGet(s, pString) '返回正则匹配\d[^_]*\d
Dim matchs, regex
regGet = ""
On Error Resume Next
Dim temp, N
Set regex = CreateObject("VBScript.RegExp")
With regex
.Global = True
.IgnoreCase = True
.Pattern = pString
Set matchs = .Execute(s)
End With
regGet = matchs(0).Value
Set regex = Nothing
Set matchs = Nothing
End Function

复制代码

补充内容 (2020-9-18 14:55):
最新更新版本http://excel880.com/blog/archives/6955

梁三刀木 · 发表于 2017-1-10 14:51

你的作品日期是2016-01-04，还是 2017-01-04？

百度不到去谷歌 · 发表于 2017-1-18 23:27

梁三刀木发表于 2017-1-10 14:51
你的作品日期是2016-01-04，还是 2017-01-04？

2017年啊手误打错了

gaozengxun · 发表于 2017-3-25 16:26

占一座位，好好学习

506981919 · 发表于 2017-4-27 23:20

不错的天气预报vba

bbmouse · 发表于 2019-3-15 15:08

收藏学习，这个很有用

bbmouse · 发表于 2019-5-30 11:46

这个怎么不能用了

menglee · 发表于 2020-9-17 10:20

楼主能不能在你这个功能上进行扩展呢，筛选省内或者周边城市，适合进行自驾露营游泳等活动的功能。比如，天气太热、下雨，不适合露营，天气太热适合游泳。天气太冷不适合游泳，有云有雨适合爬山看云海等等。

渭水之洲 · 发表于 2023-6-2 11:22

您好，请问下天气网城市代码能否从表格里面获取呢？网址上面不是很全

		自动登录	找回密码
密码			免费注册

[分享] VBA网抓之自定义EXCEL天气预报函数可查询最近7天的天气

评分