<%@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>
以上为源码部份
发表评论