I work in a local portal and the weather on the website needs to be updated every day. Over time, I felt quite troublesome, so I wrote a timed news thief. I posted it and refer to the system requirements: Support FSO, server UDP TCP/IP is not blocked.
Here is the content of the thief:
| FileName TianQi.asp Write By Niaooked 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=Mianyang,False 'This place is changed to your own address 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>,),weather) for i= 1 to ubund(body1) body3=split(body1(i),<td) weather=weather & document.write(& i&$ & weather & HTMLEncode(trim(body3(0))) & ); & vbcrlf next weather=replace(weather,1$,<FONT color=#ffffffff>【Today】</FONT>) weather=replace(weather,2$,<FONT color=#ffffff>【Tomorrow】</FONT>) weather=replace(weather,3$,<FONT color=#ffffffff>【the day after day】</FONT>) Set fs= CreateObject(Scripting.FileSystemObject) Set f = fs.CreateTextFile(request.ServerVariables(APPL_PHYSICAL_PATH)& tq.js, True) f.write(document.write('Mianyang weather forecast:'); &vbcrlf & replace(weather,<BR>,)) f.close Set f = nothing Set fs = nothing response.write Mianyang weather forecast:& weather Set oXMLHTTP = Nothing if err.number<>0 then There was an error response.write, error description: &err.description & <br>Error source& 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), ') 'Single quote filtering 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 %> |