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

    本人就职于一个本地门户网站，每天网站上的天气都得更新。久而久之感到相当麻烦，于是写了一个定时的新闻小偷，帖出来大家参考一下系统要求: 支持FSO, 服务器UDP　TCP/IP 没有屏蔽。

　　下面是小偷的内容：
clearcase/" target="_blank" >cccccc width="90%" align=center bgColor=#e3e3e3 border=1>

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 %＞

原文转自：http://www.ltesting.net