'//VBS获取天气预报 @CODE BY Broly
'//我的博客：http://blog.sina.com.cn/brolyblog
'//声明：此VBS由Broly制作，部分数据来自互联网，代码仅作学习研究之用。使用前请三思而行，产生不良后果均与本人无关！
Dim re , colMa , fso , f
Dim url,txt
'下面的这个地址是广州的。如果其他城市，可以去weather.news.qq.com找对应城市的url修改即可
url="http://weather.news.qq.com/inc/07_dc292.htm"
txt=getHTTPPage(url)
Set re=New RegExp
re.Global=True
re.IgnoreCase=True
re.Pattern="[\u4e00-\u9fa5]+</strong>"
Set colMa=re.Execute(txt)
title="天气预报[广州] v2.0 @BY Broly"
city=Left(colMa.Item(0),Len(colMa.Item(0))-9)
content="城市："&city&Space(8)&"今天是"&Date&vbCrLf&vbCrLf
For i=0 To 2
  Select Case i
    Case 0:content=content & "今天： "
    Case 1:content=content & "明天： "
    Case 2:content=content & "后天： "
  End Select
  re.Pattern=">([\u4e00-\u9fa5]*)<br>(.*)\r*\n*<br>"
  content=content & re.Replace(re.Execute(txt).Item(i),"$1") & Space(8)
  content=content & re.Replace(re.Execute(txt).Item(i),"$2") & Space(8)
  re.Pattern="<br>([\u4e00-\u9fa5]+.*)</td>"
  content=content & re.Replace(re.Execute(txt).Item(i),"$1") & vbCrLf
Next
MsgBox content,vbOKonly,title
WScript.Quit

Function getHTTPPage(url) 
Dim Http 
Set Http=CreateObject("MSXML2.XMLHTTP") 
Http.open "GET",url,false 
Http.send() 
If Http.readystate<>4 then 
Exit Function 
End If 
getHTTPPage=bytesToBSTR(Http.responseBody,"GB2312") 
Set http=nothing 
If err.number<>0 then err.Clear 
End Function 
Function BytesToBstr(body,Cset) 
Dim objstream 
Set objstream =CreateObject("adodb.stream") 
With objstream
  .Type = 1 
  .Mode = 3 
  .Open 
  .Write body 
  .Position = 0 
  .Type = 2 
  .Charset = Cset 
  BytesToBstr = .ReadText 
  .Close 
End with
Set objstream = nothing 
End Function
复制代码