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

     本人就职于一个本地门户网站，每天网站上的天气都得更新。久而久之感到相当麻烦，于是写了一个定时的新闻小偷，帖出来大家参考一下系统要求: 支持FSO, 服务器UDP　TCP/IP 没有屏蔽
  
  下面是小偷的内容
  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
  %>
  
  
    做人要厚道，请注明转自chinazhan中国站长(www.ChinaZhan.com)。