asp天气预报采集代码

<
%
&
#39
此程序用来获取北京的天气预报，可以将北京换成你想要的地点。
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) 
&
#39
 

 
 
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=&
#39
center&
#39
>
<
font 
color=&
#39
red&
#39
>
<
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

&
#39
截取字符串,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=&
#39
center&
#39
>
没有找到需要的内容。<
/p>
"

 
 
Err.Clear
 
 
Exit 
Function
 
Else
 
 
strCut 
= 
Mid(strHtml,S1,S2-S1)
 
End 
If
End 
Function

&
#39
去掉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 

%>