用ASP+XMLHTTP編寫一個天氣預報程序

某人就職于一個本地門戶網(wǎng)站，每天網(wǎng)站上的天氣都得更新。久而久之感到相當麻煩，于是寫了一個定時的新聞小偷，帖出來大家參考一下系統(tǒng)要求: 支持FSO, 服務器UDP　TCP/IP 沒有屏蔽。
    下面是小偷的內(nèi)容：
    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
    %＞