天气预报抓取

no-cache.asp

<%
'**************清除缓存************
Response.Expires = 0
Response.Expiresabsolute = Now() - 1
Response.AddHeader "pragma","no-cache"
Response.AddHeader "cache-control","private"
Response.CacheControl = "no-cache"

%>

unicode.asp

<%
Response.Charset="UTF-8"
Session.CodePage=65001
%>

weather.asp

<%@LANGUAGE="VBSCRIPT" CODEPAGE="65001"%>
<!--#include virtual="unicode.asp"-->
<!--#include virtual="no_cache.asp"-->

<%
on error resume next
Dim oXMLHTTP  'As Object
Dim oCategories  'As Object
Dim BodyText
Set oXMLHTTP = CreateObject("Microsoft.XMLHTTP")
oXMLHTTP.open "GET","http://weather.news.qq.com/inc/ss252.htm",False
oXMLHTTP.send
BodyText=oXMLHTTP.responsebody
BodyText=BytesToBstr(BodyText,"GB2312")

BodyText=mid(BodyText,instr(BodyText,"</style>"),instr(BodyText,"<script>"))

AearAddr=instr(BodyText,"r_tembg4.gif")
BodyText=mid(BodyText,AearAddr)

FristLocation=instr(BodyText,">")
LastLocation=instr(BodyText,"</")
AearAddr=mid(BodyText,FristLocation+1,LastLocation-FristLocation-1)
Response.Write(AearAddr)

WetherAddr=instr(BodyText,"r_tembg5.gif")
BodyText=mid(BodyText,WetherAddr)
FristLocation=instr(BodyText,">")
LastLocation=instr(BodyText,"</")
WetherAddr=mid(BodyText,FristLocation+1,LastLocation-FristLocation-1)
Response.Write(WetherAddr)

TemperAddr=instr(BodyText,"tem1.gif")
BodyText=mid(BodyText,TemperAddr)
BodyText=mid(BodyText,instr(BodyText,"<td"))
FristLocation=instr(BodyText,">")
LastLocation=instr(BodyText,"</")
TemperAddr=mid(BodyText,FristLocation+1,LastLocation-FristLocation-1)
Response.Write(TemperAddr)

WindAddr=instr(BodyText,"tem2.gif")
BodyText=mid(BodyText,WindAddr)
BodyText=mid(BodyText,instr(BodyText,"<td"))
FristLocation=instr(BodyText,">")
LastLocation=instr(BodyText,"</")
WindAddr=mid(BodyText,FristLocation+1,LastLocation-FristLocation-1)
Response.Write(WindAddr)

Set oXMLHTTP = Nothing
if err.number<>0 then
 response.write "出错了，错误描述："&err.description & "<br>错误来源"& err.source
 response.End()
end if

Function BytesToBstr(body,Cset)
 dim objstream
 set objstream = Server.CreateObject("adodb.stream")
 objstream.Type = 1
 objstream.Mode =3
 objstream.Open
 objstream.Write body
 objstream.Position = 0
 objstream.Type = 2
 objstream.Charset = Cset
 BytesToBstr = objstream.ReadText
 objstream.Close
 set objstream = nothing
End Function

Public Function HTMLEncode(fString)
 If Not IsNull(fString) Then
 fString = replace(fString, ">", ">")
 fString = replace(fString, "<", "<")
 fString = Replace(fString, CHR(32), " ")
 fString = Replace(fString, CHR(9), " ")
 fString = Replace(fString, CHR(34), """")
 fString = Replace(fString, CHR(39), "'")
 fString = Replace(fString, CHR(13), "")
 fString = Replace(fString, CHR(10) & CHR(10), "</P><P> ")
 fString = Replace(fString, CHR(10), "<BR> ")
 HTMLEncode = fString
 End If
End Function
%>