用ASP+XMLHTTP编写天气预报程序
<A>本人就职于一个本地门户网站，每天网站上的天气都得更新。久而久之感到相当麻烦，于是写了一个定时的新闻小偷，帖出来大家参考一下系统要求: 支持FSO, 服务器UDP TCP/IP 没有屏蔽。 <BR><BR> 下面是小偷的内容：<BR><BR>FileName TianQi.asp<BR>Write By Niaoked QQ408611119<BR>www.knowsky.com<BR>＜%<BR> if hour(now)=9 and minute(now)＜30 then<BR> getCategories()<BR> end if <BR> Function getCategories()<BR> on error resume next<BR> Dim oXMLHTTP ' As Object<BR> Dim oCategories ' As Object<BR> Dim BodyText<BR> Dim Pos,Pos1<BR> Set oXMLHTTP = CreateObject("Microsoft.XMLHTTP")<BR> '--- set the XMLHTTP call and issue send (no parm as category <BR> '--- is included in URL<BR> oXMLHTTP.open "GET","http://weather.china.com.cn/travel_gntq.php?cityid=56196;cityname=绵阳",False '这个地方换成你自己的地址<BR> oXMLHTTP.send <BR> '--- load the response into the Categories data island <BR> BodyText=oXMLHTTP.responsebody<BR> BodyText=BytesToBstr(BodyText,"gb2312")<BR> Pos=Instr(BodyText,"＜body")<BR> pos1=Instr(BodyText,"＜/body＞")<BR> BodyText=mid(BodyText,pos,pos1)<BR> BodyText=split(BodyText,"＜table")<BR> Pos=Instr(BodyText(4),"＜tr")<BR> pos1=Instr(BodyText(4),"＜/tr＞")<BR> Body=mid(BodyText(4),pos,len(BodyText(4))-pos)<BR> body=split(body,"＜/table＞")<BR> body1=split(replace(replace(replace(body(0),"＜br＞",""),"＜/td＞",""),"＜/tr＞",""),"天气")<BR> for i= 1 to ubound(body1)<BR> body3=split(body1(i),"＜td")<BR> weather=weather ; "document.write("""; i;"$" ; "天气" ; HTMLEncode(trim(body3(0))) ; """);" ; vbcrlf<BR> next<BR> weather=replace(weather,"1$","＜FONT color=#ffffff＞【今天】＜/FONT＞")<BR> weather=replace(weather,"2$","＜FONT color=#ffffff＞【明天】＜/FONT＞")<BR> weather=replace(weather,"3$","＜FONT color=#ffffff＞【后天】＜/FONT＞")<BR> Set fs = CreateObject("Scripting.FileSystemObject")<BR> Set f = fs.CreateTextFile(request.ServerVariables("APPL_PHYSICAL_PATH"); "tq.js", True)<BR> f.write("document.write('绵阳天气预报:');" ;vbcrlf ; replace(weather,"＜BR＞",""))<BR> f.close<BR> Set f = nothing<BR> Set fs = nothing<BR> response.write "绵阳天气预报:"; weather<BR> Set oXMLHTTP = Nothing <BR> if err.number＜＞0 then<BR> response.write "出错了，错误描述：";err.description ; "＜br＞错误来源" err.source<BR> response.End()<BR> end if<BR> End Function <BR></A><A>Function BytesToBstr(body,Cset)<BR> dim objstream<BR> set objstream = Server.CreateObject("adodb.stream")<BR> objstream.Type = 1<BR> objstream.Mode =3<BR> objstream.Open<BR> objstream.Write body<BR> objstream.Position = 0<BR> objstream.Type = 2<BR> objstream.Charset = Cset<BR> BytesToBstr = objstream.ReadText <BR> objstream.Close<BR> set objstream = nothing<BR> End Function<BR> Public Function HTMLEncode(fString)<BR> If Not IsNull(fString) Then<BR> fString = replace(fString, "＞", ">")<BR> fString = replace(fString, "＜", "<")<BR> fString = Replace(fString, CHR(32), " ") ';nbsp;<BR> fString = Replace(fString, CHR(9), " ") ';nbsp;<BR> fString = Replace(fString, CHR(34), """)<BR> fString = Replace(fString, CHR(39), "'") '单引号过滤<BR> fString = Replace(fString, CHR(13), "")<BR> fString = Replace(fString, CHR(10) ; CHR(10), "＜/P＞＜P＞ ")<BR> fString = Replace(fString, CHR(10), "＜BR＞ ")<BR> HTMLEncode = fString<BR> End If<BR> End Function<BR>%＞ <BR></A> <P>没人支持俺.俺自己支持,呵呵</P> 来了来了只是晚了两年，，没事，还是支持！！哈哈 好像太长了
页:
[1]