I work for a local portal, and the weather on the website needs to be updated every day. Over time, it became quite troublesome, so I wrote a scheduled news thief. Please refer to the system requirements after posting it: Support FSO, server UDP TCP/IP.
The following is the content of the thief.
FileName TianQi.asp
Write By Nioked QQ408611119
www.downcodes.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
DimBodyText
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 'Replace this place with 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 ubound(body1)
body3=split(body1(i),"<td")
weather=weather & "document.write("""& i&"$" & "Weather" & HTMLEncode(trim(body3(0))) & """);" & vbcrlf
next
weather=replace(weather,"1$","<FONT color=#ffffff>【Today】</FONT>")
weather=replace(weather,"2$","<FONT color=#ffffff>【Tomorrow】</FONT>")
weather=replace(weather,"3$","<FONT color=#ffffff>【The day after tomorrow】</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
response.write "An error occurred, 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
%>