用ASP+XMLHTTP编写一个天气预报程序

    
  
  　　本人就职于一个本地门户网站，每天网站上的天气都得更新。久而久之感到相当麻烦，于是写了一个定时的新闻小偷，帖出来大家参考一下系统要求: 支持FSO, 服务器UDP　TCP/IP 没有屏蔽。
  
  　　下面是小偷的内容：
  
  FileName TianQi.ASP
  Write By Niaoked QQ408611119
  www.knowsky.com
  ＜%
  　if hour(now)=9 and minute(now)＜30 then
  　　getCategories()
  　end if
  　Function getCategories()
  　　on error resume next
  　　Dim oXMLHTTP ' As Object
  　　Dim oCategories ' As Object
  　　Dim BodyText
  　　Dim Pos,Pos1
  　　Set oXMLHTTP = CreateObject("Microsoft.XMLHTTP")
  　　'--- set the XMLHTTP call and issue send (no parm as category
  　　'--- is included in URL
  　　oXMLHTTP.open "GET","http://weather.china.com.cn/travel_gntq.PHP?cityid=56196&cityname=绵阳",False '这个地方换成你自己的地址
  　　oXMLHTTP.send
  　　'--- load the response into the Categories data island
  　　BodyText=oXMLHTTP.responsebody
  　　BodyText=BytesToBstr(BodyText,"gb2312")
  　　Pos=Instr(BodyText,"＜body")
  　　pos1=Instr(BodyText,"＜/body＞")
  　　BodyText=mid(BodyText,pos,pos1)
  　　BodyText=split(BodyText,"＜table")
  　　Pos=Instr(BodyText(4),"＜tr")
  　　pos1=Instr(BodyText(4),"＜/tr＞")
  　　Body=mid(BodyText(4),pos,len(BodyText(4))-pos)
  　　body=split(body,"＜/table＞")
  　　body1=split(replace(replace(replace(body(0),"＜br＞",""),"＜/td＞",""),"＜/tr＞",""),"天气")
  　　for i= 1 to ubound(body1)
  　　　body3=split(body1(i),"＜td")
  　　　weather=weather & "document.write("""& i&"$" & "天气" & HTMLEncode(trim(body3(0))) & """);" & VBcrlf
  　　next
  　　weather=replace(weather,"1$","＜FONT color=#ffffff＞【今天】＜/FONT＞")
  　　weather=replace(weather,"2$","＜FONT color=#ffffff＞【明天】＜/FONT＞")
  　　weather=replace(weather,"3$","＜FONT color=#ffffff＞【后天】＜/FONT＞")
  　　Set fs = CreateObject("Scripting.FileSystemObject")
  　　Set f = fs.CreateTextFile(request.ServerVariables("APPL_PHYSICAL_PATH")& "tq.js", True)
  　　f.write("document.write('绵阳天气预报:');" &vbcrlf & replace(weather,"＜BR＞",""))
  　　f.close
  　　Set f = nothing
  　　Set fs = nothing
  　　response.write "绵阳天气预报:"& weather
  　　Set oXMLHTTP = Nothing
  　　if err.number＜＞0 then
  　　　response.write "出错了，错误描述："&err.description & "＜br＞错误来源"& err.source
  　　　response.End()
  　　end if
  　End Function
  
  　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
  %＞
  
    做人要厚道，请注明转自chinazhan中国站长(www.ChinaZhan.com)。