<%@LANGUAGE="VBSCRIPT" CODEPAGE="65001"%>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
<title>海口天气预报</title>
</head>
<body>
<%Call weather()
Sub weather()
url="http://weather.news.qq.com/inc/07_dc303.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=""57"" align=""center"" bgcolor=""#EEF3F8"">((.|\n)*?)</td></tr>"
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,"<br>"," ")
%>
<font color="#CC0000" style="font-size: 9pt">今日天气：<%=weatherStr%></font>
<%
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%>
</body>
</html> 以上为源码部份
www.shijiejunshi.net 5年前 (2014-01-18) 说
发表评论