用ASP+XMLHTTP编写一个天气预报程序

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

%＞