免费天气插件asp版本

<%codepage=936%>
<%
'***********************************************************
' 文件名: 免费天气插件asp版本,仅适用于中国用户
' 版本: mmWeather1.0
' 作者: 走过四季
' 电子邮件: maomaoysq@sohu.com
' 日期: 2010年01月14日
' 功能: 根据用户的ip地址自动获取所在城市的天气信息
' 声明:
' 本代码可以自由使用，但请保留此版权声明信息
' 如果您对本代码进行修改增强，
' 请发送一份给俺。
'**********************************************************
dim cityid,city1,city2,tmpHtml,tmpArr,tLevel,weaXML,weaHTML
tLevel = 0
weaXML = "http://service.weather.com.cn/plugin/"
weaHTML = "http://m.weather.com.cn/data/"
cityid = Trim(Request.COOKIEs("wea_cityid"))
if cityid = "" then
tmpHtml = GetUrlBody("http://fw.qq.com:80/ipaddress","gb2312")
tmpHtml = BytesToBstr(tmpHtml,"gb2312")
if tmpHtml = "" then
Response.Write("Error:Can't get ip address from qq.com.")
end if
tmpArr = Split(tmpHtml,",")
Response.COOKIEs("wea_cityip") = tmpArr(0)
city1 = tmpArr(2)
city2 = tmpArr(3)
city1 = Replace(city1,"省","")
city1 = Replace(city1,"市","")
city1 = Replace(city1,"""","")
city2 = Replace(city2,");","")
if Trim(city2) = "" then
city2 = city1
else
city2 = Replace(city2,"市","")
city2 = Replace(city2,"自治区","")
end if
city2 = Replace(city2,"""","")
'call getCityCode(city2)
if cityid = "" then
call getLocalCity("data/city.xml",0)
end if
else
call getWeather(cityid)
end if
function getLocalCity(ByVal tUrl,ByVal tLevel)
dim iPos,iPos1,cid,cArr
tmpHtml = GetUrlBody(weaXML & tUrl,"")

iPos = InStr(tmpHtml,city1)
iPos1 = InStr(tmpHtml,city2)
if tLevel<3 then
if iPos>0 then
tmpHtml = Left(tmpHtml,iPos-1)
iPos = InStrRev(tmpHtml,",")
tmpHtml = Right(tmpHtml,len(tmpHtml)-iPos)
cid = Replace(tmpHtml,"|",""):
elseif iPos1>0 then
tmpHtml = Left(tmpHtml,iPos1-1)
iPos = InStrRev(tmpHtml,",")
tmpHtml = Right(tmpHtml,len(tmpHtml)-iPos)
cid = Replace(tmpHtml,"|",""):
end if
call getLocalCity("data/city" & cid & ".xml",tLevel+1)
else
cid = Split(tmpHtml,"|")(1)
call getWeather(cid)
end if
end function
function getWeather(ByVal cid)
Response.COOKIEs("wea_cityid") = cid
tmpHtml = GetUrlBody(weaHTML & cid & ".html","")
if tmpHtml="" then
Response.Write("Error:Nothing is from "&weaHTML & cid & ".html")
else
Response.Write("")
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 GetUrlBody(ByVal URL,ByVal CharSet)
On Error Resume Next
Set Http = Server.CreateObject("MICROSOFT.XMLHTTP")
Http.Open "GET", URL, False
Http.Send
If Http.Readystate = 4 Then
If Http.Status = 200 Then
if CharSet="gb2312" then
GetUrlBody = Http.responseBody
else
GetUrlBody = Http.responseText
end if
End If
End If
End Function
%>

免费天气插件asp版本