早上在公司上班的时候，看到外边下起了雪，2008年的第一场雪，比以往来的更晚一点，呵呵，冷啊。。上海网站制作

于是想办法写抓天气预报的程序，看到了QQ的天气预报挺不错的。。呵呵。。就抓你了！

如图：

代码：

<% 上海网站制作
'On Error Resume Next
'作者：无情 来源：http://www.021-web.com.cn 转载请保留出处
Response.ContentType="text/html; charset=gb2312"

Call weather()

Sub weather()

url="http://weather.news.qq.com/inc/07_ss252.htm" '上海的天气

Call IsObjInstalled("Microsoft.XMLHTTP")

weatherStr= getHTTPPage(url)

if weatherStr="" then
response.write "抱歉,天气预报加载失败!"
else
set reg=new Regexp
reg.Multiline=True
reg.Global=false
reg.IgnoreCase=true
reg.Pattern="<td height=""77"" class=""wht2 lk37"">((.|\n)*?)</td>"

Set matches = reg.execute(weatherStr) 上海网站制作
For Each match1 in matches
weatherStr=match1.Value
Next
Set matches = Nothing
Set reg = Nothing

if InStr(weatherStr,"没有找到与")>0 then
response.write "抱歉,天气预报加载失败!" 上海网站制作
Else
weatherStr=Replace(weatherStr,"<td height=""77"" class=""wht2 lk37"">","")
weatherStr=Replace(weatherStr,"<div class=""txbd"">","")
weatherStr=Replace(weatherStr,"</div>"," ")
weatherStr=Replace(weatherStr,"</td>","") 上海网站制作

response.write "上海天气预报："&weatherStr&""

end if 
 上海网站制作
end if

End Sub

'// 采用 Microsoft.XMLHTTP　组件采集数据
Function getHTTPPage(url)
'on error resume next
dim http
set http=Server.createobject("Microsoft.XMLHTTP")
Http.open "GET",url,false
Http.send()
if Http.readystate<>4 then
exit function  上海网站制作
end if
getHTTPPage=bytes2BSTR(Http.responseBody)
set http=nothing
if err.number<>0 then err.Clear
End function

'// 采用 ADODB.Stream　处理采集到的数据，把二进制的文件转成文本字符
Function Bytes2bStr(vin)
Dim BytesStream,StringReturn
Set BytesStream = Server.CreateObject("ADODB.Stream")
BytesStream.Type = 2
BytesStream.Open
BytesStream.WriteText vin
BytesStream.Position = 0
BytesStream.Charset = "GB2312"
BytesStream.Position = 2
StringReturn =BytesStream.ReadText
BytesStream.close
Set BytesStream = Nothing
Bytes2bStr = StringReturn
End Function

'//检查组件,采用xmlhttp抓取网页还是AspHTTP

Function IsObjInstalled(strClassString)
' On Error Resume Next
IsObjInstalled = False
Err = 0
Dim xTestObj
Set xTestObj = Server.CreateObject(strClassString)

If 0 = Err Then
If AspHttpOpen=1 Then
IsObjInstalled = True
Response.write "系统不支持 XMLHTTP 组件"
'Response.write "当前组件 ASPHTTP"
response.end() 上海网站制作
Else
IsObjInstalled = False
'Response.write "当前组件 XMLHTTP"
End If
Else 上海网站制作
IsObjInstalled = False
'Response.write "当前组件 XMLHTTP"
End If

Set xTestObj = Nothing
Err = 0

End Function
%> 上海网站制作