http:///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 "&nbsp;&nbsp;>>参数： " & 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 "&nbsp;&nbsp;>>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 "&nbsp;&nbsp;>>Content-Type:" & oHttp.getResponseHeader("Content-Type") & "<br />" Response.Write "&nbsp;&nbsp;>>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 "&nbsp;&nbsp;>>没有返回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 "&nbsp;&nbsp;>>发现 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 "&nbsp;&nbsp;>>准备分析 <u>" & tRefUrl & "</u><br />" Response.Write "</p>" GetAbsoluteURL=GetAbsoluteURL(tRefUrl,iStep) Exit Function Else Response.Write "&nbsp;&nbsp;>>没发现 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 "&nbsp;&nbsp;>>Content-Type:" & oHttp.getResponseHeader("Content-Type") & "<br />" Response.Write "&nbsp;&nbsp;>>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 "&nbsp;&nbsp;>><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>