asp天氣預報采集代碼

<%
'此程序用來獲取北京的天氣預報，可以將北京換成你想要的地點。
strurl="http://weather.tq121.com.cn/mapanel/index1.PHP?city=北京"
s1="<table width=""166"" height=""15""  border=""0"" cellpadding=""0"" cellspacing=""0"">"
s2="<table width=""169"" height=""37""  border=""0"" cellpadding=""0"" cellspacing=""5"">"
 Dim j1,l,b(3)   
  strTmp = GetHTTPPage(strurl)   
  wstr=strCut(strTmp, s1,s2,2) ' 
  wstr=Replace(s1&#38;wstr,"<br>","|")
  wstr=Replace(wstr,"</table>","</table>|")
  wstr=RemoveHtml(wstr) 
  wstr=Replace(wstr,Chr(10),"")
  wstr=Replace(wstr,Chr(32),"")
  wstr=Replace(wstr,"&#38;nbsp;","")
  str=Split(wstr,"|")
  For i=0 To 3
   response.write str(i)&#38;"<br>"
  next
response.End
%>
<%
Function regExReplace(sSource,patrn, replStr) 
Dim regEx, str1 
str1 = sSource 
Set regEx = New RegExp 
regEx.Pattern = patrn 
regEx.IgnoreCase = True 
regEx.Global = True 
regExReplace = regEx.Replace(str1, replStr) 
End Function 

Function getHTTPPage(url) 
 On Error Resume Next
 dim http 
 set http=Server.createobject("Microsoft.XMLHTTP") 
 Http.open "GET",url,false 
 Http.send() 
 if Http.readystate<>4 then
  exit function 
 end if 
 getHTTPPage=bytesToBSTR(Http.responseBody,"GB2312")
 set http=nothing
 If Err.number<>0 then 
  Response.Write "<p align='center'><font color='red'><b>服務器獲取文件內容出錯</b></font></p>" 
  Err.Clear
 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

'截取字符串,1.包括起始和終止字符，2.不包括
Function strCut(strContent,StartStr,EndStr,CutType)
 Dim strHtml,S1,S2
 strHtml = strContent
 On Error Resume Next
 Select Case CutType
 Case 1
  S1 = InStr(strHtml,StartStr)
  S2 = InStr(S1,strHtml,EndStr)+Len(EndStr)
 Case 2
  S1 = InStr(strHtml,StartStr)+Len(StartStr)
  S2 = InStr(S1,strHtml,EndStr)
 End Select
 If Err Then
  strCute = "<p align='center'>沒有找到需要的內容。</p>"
  Err.Clear
  Exit Function
 Else
  strCut = Mid(strHtml,S1,S2-S1)
 End If
End Function

'去掉Html代碼
Function RemoveHtml( strText ) 
    Dim nPos1
    Dim nPos2
    
    nPos1 = InStr(strText, "<") 
    Do While nPos1 > 0 
        nPos2 = InStr(nPos1 + 1, strText, ">") 
        If nPos2 > 0 Then 
            strText = Left(strText, nPos1 - 1) &#38; Mid(strText, nPos2 + 1) 
        Else 
            Exit Do 
        End If 
        nPos1 = InStr(strText, "<") 
    Loop 
    
    RemoveHtml = strText 
End Function 
%>