asp根据访问者ip地址获取天气预报信息

根据访问用户IP地址自动获取天气预报下载中的asp版本代码的更新
+展开
-HTML
<%@ language="vbscript" codepage="936"%>
<%
function RemoveHTML(str)
  dim r:set r=new RegExp:r.ignorecase=true:r.global=true:r.pattern="<[^>]+>"
  RemoveHTML=r.replace(str,"")
  r.pattern="\s*"
  RemoveHTML=r.replace(RemoveHTML,"")
  set r=nothing
end function

function getip()
  dim ip
  ip =Request.ServerVariables("http_x_forwarded_for")
  if ip="" then ip=Request.ServerVariables("remote_addr")
  getip=ip
end function

function nowdate(d)
  nowdate=year(d)&"-"&month(d)&"-"&day(d)
end function

Function BytesToBstr(strBody,CodeBase) 
  dim obj 
  set obj=Server.CreateObject("Adodb.Stream"
  obj.Type=1 
  obj.Mode=3 
  obj.Open 
  obj.Write strBody 
  obj.Position=0 
  obj.Type=2 
  obj.Charset=CodeBase 
  BytesToBstr=obj.ReadText 
  obj.Close 
  set obj=nothing 
End Function 

function js(v)
  js=replace(v,"'","\'")
end function


function getWeather()
  dim ip,json,arr,ipnum,addr,xhr,htmlbody,r,mc,tmparr:json="var weather={success:false,err:'无法获取地址'};":addr=""
  ip=getip()
  if ip<>"" then
    arr=split(ip,".")
    ipnum=256*256*256*arr(0) + 256*256*arr(1) + 256*arr(2) +arr(3)'转换为数字
    '===========================
     dim cn,rs:set cn=server.createobject("adodb.connection")
     cn.open "驱动字符串"
     set rs=cn.execute("select addr from ipdb where ipe>=" & ipNum & " and ipb<=" & ipNum)
     if not(rs.eof or rs.bof) then addr=rs(0)
     rs.close:set rs=nothing:cn.close:set cn=nothing
     if addr="" then addr="桂林"
    '=========================
    if addr<>"" then
      Set xhr=Server.CreateObject("Microsoft.XMLHTTP")
      xhr.open "get","http://php.weather.sina.com.cn/search.php?city="& addr,False
      xhr.send
      htmlbody=bytestobstr(xhr.responseBody,"gb2312")'获取返回的html内容,注意要使用gb2312来获取文本内容
      Set xhr=Nothing
      set r=new regexp:r.ignorecase=true:r.global=true
      set dir=new regexp:dir.ignorecase=true:dir.global=true
      set dsrx=new regexp:dsrx.ignorecase=true:dsrx.global=true
      set tbrx=new regexp:tbrx.ignorecase=true:tbrx.global=true
      set tdrx=new regexp:tdrx.ignorecase=true:tdrx.global=true
      r.pattern=addr&",([^,]+),([^,]+),风力:([^']+)"
      dir.pattern="<li>\s*风向:([^<]+)</li>"
      dsrx.pattern="<div\s+class=""box_c\s*weather_date""\s*>([\s\S]+?)</div>"
      tbrx.pattern="<table\s+class=""cell""[^>]*>([\s\S]+?)</table>"
      tdrx.pattern="<td>([\s\S]+?)</td>"
      if r.test(htmlbody) then
         dim dt:dt=now
         set m=r.execute(htmlbody)
         set dirm=dir.execute(htmlbody)
         json="{success:true,addr:'" &js(addr) & "',weathers:[{d:'" + nowdate(dt)& "'"&_
              ",weather:'" & m.item(0).submatches(0) & "',tmp:'" & m.item(0).submatches(1) & "',dir:'" & dirm.item(0).submatches(0) & "',strong:'" & m.item(0).submatches(2) & "'}"
         if dsrx.test(htmlbody) then
            set m=dsrx.execute(htmlbody)
            htmlbody=m.item(0).submatches(0)
            set mc=tbrx.execute(htmlbody)
            dim mctd,dweather,nweather,dtmp,ntmp,ndir,ddir,idx
            if mc.count>1 then
             idx=mc.count
             for i=0 to idx
               set mctd=tdrx.execute(mc.item(i).submatches(0))
               dweather=mctd.item(4).submatches(0):nweather=mctd.item(5).submatches(0)
               if dweather<>nweather then dweather=dweather & " 转 " & nweather
               dtmp = RemoveHTML(mctd.item(6).submatches(0)):ntmp = RemoveHTML(mctd.item(7).submatches(0))
               ddir =mctd.item(8).submatches(0):ndir = mctd.item(9).submatches(0)
               if ddir <> ndir then ddir = ddir & " 转 " & ndir
               dt = dateadd("d",1,dt)
               json =json& ",{d:'" &nowdate(dt)& "',weather:'" & dweather & "',tmp:'" & dtmp & "~" & ntmp & "',dir:'" & ddir & "'}"
             next
           end if
        end if
        json =json& "]};"
     end if
   end if
 end if
 getWeather=json
end function

response.charset="gb2312"
response.write getWeather()
 %>

加支付宝好友偷能量挖...


原创文章,转载请注明出处:asp根据访问者ip地址获取天气预报信息

评论(0)Web开发网
阅读(143)喜欢(0)Asp/VBScript