<%
'此程序用来获取北京的天气预报，可以将北京换成你想要的地点。
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&wstr,"<br>","|")
  wstr=Replace(wstr,"</table>","</table>|")
  wstr=RemoveHTML(wstr)
  wstr=Replace(wstr,Chr(10),"")
  wstr=Replace(wstr,Chr(32),"")
  wstr=Replace(wstr,"&nbsp;","")
  str=Split(wstr,"|")
  For i=0 To 3
   response.write str(i)&"<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) & Mid(strText, nPos2 + 1)
        Else
            Exit Do
        End If
        nPos1 = InStr(strText, "<")
    Loop
   
    RemoveHTML = strText
End Function
%>

评论