本人就职于一个本地门户网站，每天网站上的天气都得更新。久而久之感到相当麻烦，于是写了一个定时的新闻小偷，帖出来大家参考一下系统要求: 支持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,"pos1=Instr(BodyText,"")

BodyText=mid(BodyText,pos,pos1)

BodyText=split(BodyText,"

Pos=Instr(BodyText(4),"

pos1=Instr(BodyText(4),"")

Body=mid(BodyText(4),pos,len(BodyText(4))-pos)

body=split(body,"

")

body1=split(replace(replace(replace(body(0),"

",""),"",""),"",""),"天气")

for i= 1 to ubound(body1)

body3=split(body1(i),"

weather=weather & "document.write("""& i&"$" & "天气" & HTMLEncode(trim(body3(0))) & """);" & vbcrlf

next

weather=replace(weather,"1$","【今天】")

weather=replace(weather,"2$","【明天】")

weather=replace(weather,"3$","【后天】")

Set fs = CreateObject("Scripting.FileSystemObject")

　Set f = fs.CreateTextFile(request.ServerVariables("APPL_PHYSICAL_PATH")& "tq.js", True)

　f.write("document.write('绵阳天气预报:');" &vbcrlf &　replace(weather,"

",""))

　f.close

　Set f = nothing

　Set fs = nothing

response.write "绵阳天气预报:"& weather

Set oXMLHTTP = Nothing

if err.number0 then

response.write "出错了，错误描述："&err.description & "

错误来源"& 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), "

")

　 fString = Replace(fString, CHR(10), "

")

　 HTMLEncode = fString

　End If

End Function

%>