asp实现天气预报的抓取

'作者：无情 来源： 转载请保留出处
Response.ContentType="text/html; charset=gb2312"


url="http://weather.news.qq.com/inc/07_ss255.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

'// 采用 Microsoft.XMLHTTP　组件采集数据
Function getHTTPPage(url) 
 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)
 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.end()
  Else
  IsObjInstalled = False
  'Response.write "当前组件 XMLHTTP"
  End If
 Else
  IsObjInstalled = False
  'Response.write "当前组件 XMLHTTP"
 End If
 
 Set xTestObj = Nothing
 Err = 0
End Function
%>