采用XMLHTTP编写一个天气预报的程序

本人就职于一个本地门户网站,每天网站上的天气都得更新。久而久之感到相当麻烦,于是写了一个定时的新闻小偷,帖出来大家参考一下系统要求: 支持FSO, 服务器UDP TCP/IP 没有屏蔽

下面是小偷的内容
FileName TianQi.asp
Write By Niaoked QQ408611119
www.knowsky.com

 1   
 2if hour(now)=9 and minute(now)<30 then   
 3getCategories()   
 4end if   
 5Function getCategories()   
 6on error resume next   
 7Dim oXMLHTTP ' As Object   
 8Dim oCategories ' As Object   
 9Dim BodyText   
10Dim Pos,Pos1   
11Set oXMLHTTP = CreateObject("Microsoft.XMLHTTP")   
12'--- set the XMLHTTP call and issue send (no parm as category   
13'--- is included in URL   
14oXMLHTTP.open "GET"," http://weather.china.com.cn/travel_gntq.php?cityid=56196&cityname =绵阳",False '这个地方换成你自己的地址   
15oXMLHTTP.send   
16'--- load the response into the Categories data island   
17BodyText=oXMLHTTP.responsebody   
18BodyText=BytesToBstr(BodyText,"gb2312")   
19Pos=Instr(BodyText,"

<body") pos1='Instr(BodyText,"&lt;/body'>")
BodyText=mid(BodyText,pos,pos1)
BodyText=split(BodyText,"<table") pos='Instr(BodyText(4),"&lt;tr")' pos1='Instr(BodyText(4),"&lt;/tr'>")
Body=mid(BodyText(4),pos,len(BodyText(4))-pos)
body=split(body,"")
body1=split(replace(replace(replace(body(0),"<br/>",""),"",""),"",""),"天气")
for i= 1 to ubound(body1)
body3=split(body1(i),"<td") """);"="" "document.write("""&="" "天气"="" &="" color="#ffffff" htmlencode(trim(body3(0)))="" i&"$"="" next="" vbcrlf="" weather='replace(weather,"1$","&lt;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")&amp; "tq.js", True)
f.write("document.write('绵阳天气预报:');" &amp;vbcrlf &amp; replace(weather,"<br/>",""))
f.close
Set f = nothing
Set fs = nothing
response.write "绵阳天气预报:"&amp; weather
Set oXMLHTTP = Nothing
if err.number&lt;&gt;0 then
response.write "出错了,错误描述:"&amp;err.description &amp; "<br/>错误来源"&amp; 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, "&gt;", "&gt;")
fString = replace(fString, "&lt;", "&lt;")
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) &amp; CHR(10), "<p> ")
fString = Replace(fString, CHR(10), "<br/> ")
HTMLEncode = fString
End If
End Function

Published At
Categories with Web编程
Tagged with
comments powered by Disqus