<%'此程序用来获取北京的天气预报，可以将北京换成你想要的地点。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>"  nextresponse.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 = nothingEnd 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 IfEnd 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 %>

评论