ASP截取氣象局V7網頁, 示範抓取台中市的最新預報氣候及溫度

我們的需求是截取這部分訊息Include到EIP的首頁上

程式範例如下(改編[蔡玉貴老師]自http://wa.sjps.ntpc.edu.tw/blog/View.asp?cid=955)

        <%
'--取得<td></td>間的文字內容
Function ReplaceAll(str1, patrn, replStr)
Dim regEx
Set regEx = Server.CreateObject("VBScript.RegExp") ' Create regular expression.
regEx.Pattern = patrn   ' Set pattern.
regEx.IgnoreCase = True ' Make case insensitive.
regEx.Global = True
ReplaceAll = regEx.Replace(str1, replStr)  ' Make replacement.
Set regEx = Nothing
End Function

'--判斷是否已經截取過，如果已經存在就直接秀出氣象結果，為了增加效能，
'不必每次使用者上實踐網站就前往中央氣象局，只要伺服器在特定時間前往取回，
'寫入伺服器中，每天會更新四次。爾後，一般使用者瀏覽實踐網站時，
'就會直接讀取已經事先擷取的氣象資訊，這種作法比較有效率。
Set FSO=Server.CreateObject("Scripting.FileSystemObject")
cktime = "17"
if hour(now)> 16 then '--每天上午0:00 5:00, 11:00與下午5:00 前往氣象局抓取氣象資料
  getfile=year(date)&month(date)&day(date)&"17.txt"
  cktime = "17"
ElseIf hour(now)> 10 then
  getfile=year(date)&month(date)&day(date)&"11.txt"
  cktime = "11"
ElseIf hour(now)> 4 then
  getfile=year(date)&month(date)&day(date)&"5.txt"
  cktime = "05"
else
  getfile=year(date)&month(date)&day(date)&".txt"
end if

whichfile=server.MapPath("\")&"\GetTodayWeather\"&getfile '--以當天日期作為紀錄檔

If FSO.FileExists(whichfile) then
Set txt = FSO.OpenTextFile(whichfile,1)
rline = txt.ReadAll
txt.Close
response.write rline
else
'--擷取外部網站html原始碼
dim objXMLHTTP
Dim Pos,Pos1,BodyG,Gettdtext

'--擷取中央氣象局台中地區氣象資料
URL = Request.form("URL")
if ( URL = "" ) then
 URL ="http://www.cwb.gov.tw/V7/forecast/taiwan/Taichung_City.htm"
end if

Set objXMLHTTP = Server.CreateObject("Microsoft.XMLHTTP")
objXMLHTTP.Open "GET", URL, false
objXMLHTTP.Send
strTmp = bytesToBSTR(objXMLHTTP.responseBody,"utf-8")
TimeStamp = MID(strTmp,InStr(strTmp,"發布時間")+18,2)
strTmp=MID(strTmp,InStr(strTmp,"今明預報"),550)
strTmp=MID(strTmp,InStr(strTmp,"<td>")+4,200)
degree=MID(strTmp,1,InStr(strTmp,"</td>")-1)&"℃"
strTmp=MID(strTmp,InStr(strTmp,"alt=")+5,50)
weather=MID(strTmp,1,InStr(strTmp,"title")-3)
response.write (weather&"<br>("&degree&")")
if cktime = TimeStamp then '確定已更新才存檔
Set NewFile=FSO.CreateTextFile(whichfile,True)
NewFile.Write (weather&"<br>("&degree&")")
NewFile.Close
Set NewFile=Nothing
end if
Set objXMLHTTP = Nothing
end if

'--中文轉換

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
%>