网络编程
位置：首页>> 网络编程>> Asp编程>> asp获取软件下载的真实地址！再谈获取Response.redirect重定向的URL！（2）

asp获取软件下载的真实地址！再谈获取Response.redirect重定向的URL！（2）

　来源：落伍者　发布时间：2010-03-10 22:03:00　

标签：下载地址,asp,WinHttp.WinHttpRequest,组件

asp获取软件下载的真实地址完整代码：

<％
Public Function Bytes2BSTR(v)
 Dim r,i,t,n : r = ""
 For i = 1 To LenB(v)
  t = AscB(MidB(v,i,1))
  If t < &H80 Then
   r = r & Chr(t)
  Else
   n = AscB(MidB(v,i+1,1))
   r = r & Chr(CLng(t) * &H100 + CInt(n))
   i = i + 1
  End If
 Next
 Bytes2BSTR = r
End Function
'==========================================================================================
 If Request.QueryString="ViewSource" Then
  Dim oFso : Set oFso=Server.CreateObject("Scripting.FileSystemObject")
  Dim oFil : Set oFil=oFso.OpenTextFile(Server.MapPath("URL.Asp"))
  Dim sTxt : sTxt=oFil.ReadAll()
  oFil.Close : Set oFil=Nothing : Set oFso=Nothing
  Response.ContentType="text/plain"
  Response.Write sTxt
  Response.ENd
 End If
％><?xml version="1.0" encoding="gb2312" standalone="yes"?>
<!doctype html public "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns:v="http://www.eglic.com/">
 <head>
  <title></title>
  <meta name="Generator" content="EditPlus" />
  <meta name="Author" content="eglic" />
  <meta http-equiv="Content-Type" content="text/html; charset=gb2312" />
  <meta name="CharSet" content="GB2312" />
  <link rel="stylesheet" type="text/css" href="/styles/default.css" />
  <style type="text/css">
   @media all{
    
   }
  </style>
  <script language="javascript" src="/scripts/default.js"></script>
  <script language="javascript" src="/scripts/xml.js"></script>
  <script language="javascript">//<!--
   
  //--></script>
 </head>
 <body>
  <form action="" method="POST">
   要检测的URL：<input type="text" name="URL" size="50" value="<％
    If Request.Form("URL")<>"" THen
     Response.Write Trim(Request.Form("URL"))
    Else
     Response.Write "http://www.crsky.com/view_down.asp?downd_id=8&downd=0&ID=20780&down=yes"
    End If
   ％>" />
   <input type="submit" value="提交" />
   <input type="button" value="查看源代码" onclick="JavaScript:window.open('<％=URLSelf％>?ViewSource');" />
  </form>
  <％
   Public Function GetAbsoluteURL(sUrl,ByRef iStep)
    Dim bUrl,bDat
    If iStep>15 Then
     Err.Raise vbObejctError,"递归错误","递归嵌套超过15层可能会引起程序崩溃"
    End If
    If InStr(sUrl,"://")<=0 Then sUrl="http://" & sUrl
    If InStr(sUrl,"?")>0 THen
     Dim tmpUrl : tmpUrl=split(sUrl,"?")
     bUrl=tmpUrl(0)
     bDat=tmpUrl(1)
    Else
     bUrl=sUrl
     bDat=""
    End If
    Response.Write "<p style=""border:solid 1px silver;border-top:solid 2px red;padding:5px;margin:2px;"">"
    Response.Write "第 " & iStep & " 步："
    Response.Write "正在准备获取 " & bUrl & "<br />"
    iStep=iStep+1
    if bDat<>"" Then Response.Write "  >>参数： " & bDat & "<br />"
    Dim oHttp : Set oHttp=Server.CreateObject("WinHttp.WinHttpRequest.5.1")
    oHttp.Option(6)=0 '禁止自动Redirect，最关键的
    'oHttp.Option()
    oHttp.SetTimeouts 5000,5000,30000,5000
    oHttp.Open "GET",sUrl,False
    On Error Resume Next
     oHttp.Send bDat
     If Err.Number<>0 Then
      Response.Write "<font color=""red"">发生错误：" & Err.Description & "</font><br />"
      Err.Clear
      GetAbsoluteURL=""
      Set oHttp=Nothing
      Response.Write "</p>"
      Exit Function
     End If
    On Error Goto 0
     Response.Write "  >>HTTP 状态：" & oHttp.Status & "<br />"
     If oHttp.Status<>200 And oHttp.Status<>302 Then
      Response.Write "<font color=""red"">HTTP错误：" & oHttp.StatusText & "</font><br />"
      Err.Clear
      GetAbsoluteURL=""
      Set oHttp=Nothing
      Response.Write "</p>"
      Exit Function
     End If
     Dim sLoca 
     On Error Resume Next
      sLoca=oHttp.getResponseHeader("Location")
      If Err.Number<>0 Then
       Err.Clear
       sLoca=""
      End If
     On Error Goto 0
     If sLoca = "" Then
      Response.Write "  >>Content-Type:" & oHttp.getResponseHeader("Content-Type") & "<br />"
      Response.Write "  >>Content-Length:" 
      On Error Resume Next
       Response.Write oHttp.getResponseHeader("Content-Length")
       If Err.Number<>0 THen Err.Clear
      On Error Goto 0
      Response.Write "<br />"
      Response.Write "  >>没有返回Location头，继续分析页面<br />"
      If oHttp.getResponseHeader("Content-Type")="text/html" Then '是HTML类型才继续处理
       Dim sBody : sBody=Bytes2BStr(oHttp.responseBody)
       Dim r : Set r=new Regexp
       r.MultiLine=True
       r.Global=True
       r.IgnoreCase=True
       r.Pattern="<meta.+http\-equiv\=\""refresh\"".+content=\""[^\;]+;url\=([^\""\s\>]*).*$"
       If r.Test(sBody) Then
        Response.Write "  >>发现 Refresh 地址<br />"
        Dim m : Set m=r.Execute(sBody)
        Dim tRefUrl : tRefUrl=r.Replace(m(0).Value,"$1")
        If InStr(tRefUrl,"://")<=0 Then '没有指定协议，按当前URL的位置重新设置
         Dim ind1 : ind1=InstrRev(sUrl,"/")
         sUrl=Left(sUrl,ind1)
         tRefUrl=sUrl & tRefUrl
        End If
        Set r=Nothing
        Set oHttp=Nothing
        Response.Write "  >>准备分析 <u>" & tRefUrl & "</u><br />"
        Response.Write "</p>"
        GetAbsoluteURL=GetAbsoluteURL(tRefUrl,iStep)
        Exit Function
       Else
        Response.Write "  >>没发现 Refresh Meta 转向，这可能就是最终的URL<br />"
        GetAbsoluteURL=sUrl
        Set r=Nothing
        Set oHttp=Nothing
        Response.Write "</p>"
        Exit Function
       End If
      Else
       GetAbsoluteURL=sUrl
       Set oHttp=Nothing
       Response.Write "</p>"
       Exit Function
      End If
      '这里要继续分析网页内容
     Else
      Response.Write "  >>Content-Type:" & oHttp.getResponseHeader("Content-Type") & "<br />"
      Response.Write "  >>Content-Length:" 
      On Error Resume Next
       Response.Write oHttp.getResponseHeader("Content-Length")
       If Err.Number<>0 THen Err.Clear
      On Error Goto 0
      Response.Write "<br />"
      Response.Write "  >><u>Location : " & sLoca& "</u><br />"
      Response.Write "</p>"
      '这里要生成新的URL
      If InStr(sLoca,"://")<=0 Then
       '没有指定协议，按当前URL的位置重新设置
       Dim ind : ind=InstrRev(sUrl,"/")
       sUrl=Left(sUrl,ind)
       sLoca=sUrl & sLoca
      End If
      GetAbsoluteURL=GetAbsoluteURL(sLoca,iStep)
     End If
   End Function
   If Request.Form("URL")<>"" THen
    Dim iStep : iStep=1
    Dim sAbs : sAbs=GetAbsoluteURL(Trim(Request.Form("URL")),iStep)
    Response.Write "<strong style=""color:white;background-color:red;font-size:15px;padding:3px;margin:10px;"">最终结果是：" & sAbs & "</strong>"
   End If
  ％>
 <script src="/T/mystat.asp?siteid=1"></script>
 </body>
</html>


 


第一页 上一页 1
2
0
投稿

猜你喜欢

手机版 网络编程 asp之家 www.aspxhome.com