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

百度不到去谷歌

天气预报很多人都做过,我这个版本的一部分代码也来自于网友分享,不同的是我进行升级,做了城市代码自动查询以及7天任意时间组合的参数查询
视频演示如下
http://excel880.com/blog/archives/979
代码如下

1. 'Option Explicit
   
2. '作者 百度不到去谷歌 excel880.com 作品2016-01-04
   
3. '根据城市名称查询最近7天天气预报
   
4. '预报天数为逗号分隔的参数,不写返回今天,直接写0的话是7天全部,其余形式 1-7 写哪几个就返回哪几天
   
5. '例如 天气预报("武汉", "1,2") 返回今天和明天 2,3返回明天和后天 可自由组合
   
6. Function 天气预报(城市, Optional 预报天数 = "1")
   
7. Dim brr, arr
   
8.     brr = TQYB(城市)
   
9.     If 预报天数 = 0 Then 预报天数 = "1,2,3,4,5,6,7"
   
10.     arr = Split(预报天数, ",")
    
11.     For i = 0 To UBound(arr)
    
12.         天气预报 = 天气预报 & vbCrLf & Trim(brr(Val(arr(i)) - 1))
    
13.     Next
    
14.     天气预报 = Mid(天气预报, 3)
    
15. End Function
    
16. Function TQYB(城市)  'g根据城市返回7天结果数组
    
17.     exstr = String(20, " ")
    
18.     Set regex = CreateObject("vbscript.regexp")
    
19.     regex.Global = True
    
20.     regex.Pattern = "[\u0100-\uffff]"
    
21.     arr = Split("h1,0,14,p,0,18,p,1,10,i,1,10", ",")
    
22.     Dim brr
    
23.     With CreateObject("Microsoft.XMLHTTP")
    
24.         .Open "GET", CityUrl(城市) & "?r=" & Rnd, True
    
25.         .send
    
26.         While .readystate <> 4
    
27.             DoEvents
    
28.         Wend
    
29.         If .Status <> 200 Then
    
30.             Exit Function
    
31.         End If
    
32.         mystr = .responsetext
    
33.     End With
    
34.     With CreateObject("htmlfile")
    
35.         .designmode = "on"
    
36.         .Open
    
37.         .writeln mystr
    
38.         mystr = ""
    
39.         For Each ul In .getelementsbytagname("ul")
    
40.             If ul.classname = "t clearfix" Then
    
41.                 For Each li In ul.getelementsbytagname("li")
    
42.                     For N = LBound(arr) To UBound(arr) Step 3
    
43.                         Set t = li.getelementsbytagname(arr(N))
    
44.                         st = t.Item(CInt(arr(N + 1))).innertext
    
45.                         If N + 3 < UBound(arr) Then
    
46.                             mystr = mystr & Left(st & exstr, CInt(arr(N + 2)) - regex.Execute(st).Count)
    
47.                         Else
    
48.                             mystr = mystr & st
    
49.                         End If
    
50.                     Next
    
51.                     mystr = mystr & vbCrLf
    
52.                 Next
    
53.             End If
    
54.         Next
    
55.     End With
    
56.     brr = Split(mystr, vbCrLf)
    
57.     TQYB = brr
    
58. End Function
    
59. 
    
60. 
    
61. Public Function GetBody(ByVal URL$)
    
62.     Dim ObjXML
    
63.     On Error Resume Next
    
64.     Set ObjXML = CreateObject("Microsoft.XMLHTTP")
    
65.     With ObjXML
    
66.         .Open "Get", URL, False, "", ""
    
67.         .setRequestHeader "If-Modified-Since", "0"
    
68.         .send
    
69.         GetBody = .responsetext
    
70.     End With
    
71.     ' = BytesToBstr(GetBody, Coding)
    
72.     Set ObjXML = Nothing
    
73. End Function
    
74. 
    
75. Function CityUrl(city)
    
76.     Dim s
    
77.     s = GetBody("http://www.cnblogs.com/wf225/p/4090737.html") '天气网城市代码a
    
78.     CityUrl = regGet(s, "\d+=" & city)
    
79.     If CityUrl <> "" Then CityUrl = "http://www.weather.com.cn/weather/" & Left(CityUrl, 9) & ".shtml"
    
80. End Function
    
81. Public Function regGet(s, pString) '返回正则匹配\d[^_]*\d
    
82.     Dim matchs, regex
    
83.     regGet = ""
    
84.     On Error Resume Next
    
85.     Dim temp, N
    
86.      Set regex = CreateObject("VBScript.RegExp")
    
87.     With regex
    
88.         .Global = True
    
89.         .IgnoreCase = True
    
90.         .Pattern = pString
    
91.         Set matchs = .Execute(s)
    
92.     End With
    
93.     regGet = matchs(0).Value
    
94.     Set regex = Nothing
    
95.     Set matchs = Nothing
    
96. End Function

复制代码

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

梁三刀木

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

百度不到去谷歌

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

2017年啊 手误打错了

gaozengxun

占一座位，好好学习

506981919

不错的天气预报vba

bbmouse

收藏学习，这个很有用

bbmouse

这个怎么不能用了

menglee

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

渭水之洲

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