远程获取类Asp xmlHttp 带 cookie 欺骗

来源：互联网发布：php金字塔代码编辑：程序博客网时间：2024/06/04 18:24

编者注：这个class主要用于操作asp中的xmlhttp。

首先是类定义 Cls_AspHttp.asp：
<%
''=================================================================
''飞扬远程获取类(AspHttp) 1.0.1 Bate1
'' By 奔腾的心
'' 2006-04-19
''=================================================================
Class FlyCms_AspHttp
Public oForm,oXml,Ados
Public strHeaders
Public sMethod
Public sUrl
Public sReferer
Public sSetCookie
Public sLanguage
Public sCONTENT
Public sAgent
Public sEncoding
Public sAccept
Public sData
Public sCodeBase
Private slresolveTimeout,slconnectTimeout,slsendTimeout,slreceiveTimeout
'' ============================================
'' 类模块初始化
'' ============================================
Private Sub Class_Initialize()
oForm = ""
Set oXml = Server.CreateObject("MSXML2.ServerXMLHTTP")
set Ados = Server.CreateObject("Adodb.Stream")
 slresolveTimeout = 20000 '' 解析DNS名字的超时时间,20秒
 slconnectTimeout = 20000 '' 建立Winsock连接的超时时间,20秒
 slsendTimeout = 30000 '' 发送数据的超时时间,30秒
 slreceiveTimeout = 30000 '' 接收response的超时时间,30秒
End Sub

'' ============================================
'' 返回版本信息
'' ============================================
Public Property Get Version
Version = "飞扬asphttp类1.0.0"
End Property
'' ============================================
'' 解析DNS名字的超时时间
'' ============================================
Public Property Let lresolveTimeout(LngSize)
If IsNumeric(LngSize) Then
 slresolveTimeout = Clng(LngSize)
End If
End Property
'' ============================================
'' 建立Winsock连接的超时时间
'' ============================================
Public Property Let lconnectTimeout(LngSize)
If IsNumeric(LngSize) Then
 slconnectTimeout = Clng(LngSize)
End If
End Property
'' ============================================
'' 发送数据的超时时间
'' ============================================
Public Property Let lsendTimeout(LngSize)
If IsNumeric(LngSize) Then
 slsendTimeout = Clng(LngSize)
End If
End Property
'' ============================================
'' 接收response的超时时间
'' ============================================
Public Property Let lreceiveTimeout(LngSize)
If IsNumeric(LngSize) Then
 slreceiveTimeout = Clng(LngSize)
End If
End Property
'' ============================================
'' Method
'' ============================================
Public Property Let Method(strMethod)
sMethod = strMethod
End Property
'' ============================================
'' 发送url
'' ============================================
Public Property Let Url(strUrl)
sUrl = strUrl
End Property
'' ============================================
'' Data
'' ============================================
Public Property Let Data(strData)
sData = strData
End Property
'' ============================================
'' Referer
'' ============================================
Public Property Let Referer(strReferer)
sReferer = strReferer
End Property
'' ============================================
'' SetCookie
'' ============================================
Public Property Let SetCookie(strCookie)
sSetCookie = strCookie
End Property
'' ============================================
'' Language
'' ============================================
Public Property Let Language(strLanguage)
sLanguage = strLanguage
End Property
'' ============================================
'' CONTENT-Type
'' ============================================
Public Property Let CONTENT(strCONTENT)
sCONTENT = strCONTENT
End Property
'' ============================================
'' User-Agent
'' ============================================
Public Property Let Agent(strAgent)
sAgent = strAgent
End Property
'' ============================================
'' Accept-Encoding
'' ============================================
Public Property Let Encoding(strEncoding)
sEncoding = strEncoding
End Property
'' ============================================
'' Accept
'' ============================================
Public Property Let Accept(strAccept)
sAccept = strAccept
End Property
'' ============================================
'' CodeBase
'' ============================================
Public Property Let CodeBase(strCodeBase)
sCodeBase = strCodeBase
End Property
'' ============================================
'' 建立数据传送对向!
'' ============================================
Public Function AddItem(Key, Value)
 On Error Resume Next
 Dim TempStr
 If oForm = "" Then
 oForm = Key + "=" + Server.URLEncode(Value)
 Else
 oForm = oForm + "&" + Key + "=" + Server.URLEncode(Value)
 End If
End Function
'' ============================================
'' 发送数据并取回远程数据
'' ============================================
Public Function HttpGet()
Dim sReturn
With oXml
 .setTimeouts slresolveTimeout,slconnectTimeout,slsendTimeout,slreceiveTimeout
 .Open sMethod,sUrl,False
 If sSetCookie<>"" Then
 .setRequestHeader "Cookie", sSetCookie ''设定Cookie
 End If
 If sReferer<>"" Then
 .setRequestHeader "Referer", sReferer ''设定页面来源
 Else
 .setRequestHeader "Referer", sUrl
 End If
 If sLanguage<>"" Then
 .setRequestHeader "Accept-Language", sLanguage ''设定语言
 End If
 .setRequestHeader "Content-Length",Len(sData) ''设定数据长度
 If sCONTENT<>"" Then
 .setRequestHeader "CONTENT-Type",sCONTENT ''设定接受数据类型
 End If
 If sAgent<>"" Then
 .setRequestHeader "User-Agent", sAgent ''设定浏览器
 End If
 If sEncoding<>"" Then
 .setRequestHeader "Accept-Encoding", sEncoding ''设定gzip压缩
 End If
 If sAccept<>"" Then
 .setRequestHeader "Accept", sAccept ''文档类型
 End If
 .Send sData ''发送数据
 While .readyState <> 4
 .waitForResponse 1000
 Wend
 strHeaders = .getAllResponseHeaders()
 If sCodeBase<>"" Then
 sReturn = bytes2BSTR(.responseBody)
 Else
 sReturn = .responseBody
 End If
End With
HttpGet = sReturn
End Function
'' ============================================
'' 处理二进制数据
'' ============================================
Private Function bytes2BSTR(vIn)
 strReturn = ""
 For i = 1 To LenB(vIn)
 ThisCharCode = AscB(MidB(vIn,i,1))
 If ThisCharCode < &H80 Then
 strReturn = strReturn & Chr(ThisCharCode)
 Else
 NextCharCode = AscB(MidB(vIn,i+1,1))
 strReturn = strReturn & Chr(CLng(ThisCharCode) * &H100 + CInt(NextCharCode))
 i = i + 1
 End If
 Next
 bytes2BSTR = strReturn
End Function
'' ============================================
'' 类模块注销
'' ============================================
Private Sub Class_Terminate
oForm = ""
Set oXml = Nothing
Set Ados = Nothing
End Sub
End Class
%>

function.asp 调用的代码：（简化了代码的书写）
<%
''调试代码
Sub Re1(Str)
Response.Write Str
Response.End
End Sub

Sub Rw(Str)
Response.Write Str & vbCrLf
Response.Flush
End Sub

Function HttpGet(lresolveTimeout,lconnectTimeout,lsendTimeout,lreceiveTimeout,Method,Url,Referer,Data,SetCookie,Language,CONTENT,Agent,Encoding,Accept,CodeBase)
DoGet.lresolveTimeout = lresolveTimeout
DoGet.lconnectTimeout = lconnectTimeout
DoGet.lsendTimeout     = lsendTimeout
DoGet.lreceiveTimeout = lreceiveTimeout
DoGet.Method   = Method
DoGet.Url   = Url
DoGet.Referer = Referer
DoGet.Data = Data
DoGet.SetCookie = SetCookie
DoGet.Language   = Language
DoGet.CONTENT   = CONTENT
DoGet.Agent   = Agent
DoGet.Encoding   = Encoding
DoGet.Accept   = Accept
DoGet.CodeBase   = CodeBase
HttpGet = DoGet.HttpGet()
End Function

'' ============================================
 '' 取得cookie头
 '' ============================================
 Function GetCookie(ByVal strHead, ByVal sBound)
 If strHead = "" Then
 GetCookie = ""
 Exit Function
 End If
 Dim strCookie, iCookie, bNum
 strCookie = strHead

 If strCookie <> "" And InStr(strCookie, "Set-Cookie") > 0 Then
 strCookie = Replace(strCookie, "Set-Cookie: ", "〔")
 strCookie = Replace(strCookie, ";", "〕")
 Patrn = "〔[^〕]+〕"
 strCookie = RegExpSearch(Patrn, strCookie, 0, "`")
 strCookie = Replace(strCookie, "〔", "")
 strCookie = Replace(strCookie, "〕", "")
 strCookie = Split(strCookie, "`")
 bNum = sBound
 If bNum=-1 Then
 For I=0 To UBound(strCookie)
 If iCookie = "" Then
 iCookie = strCookie(i)
 Else
 iCookie = iCookie & "; " & strCookie(i)
 End If
 Next
 Else
 If bNum > UBound(strCookie) Then
 bNum = UBound(strCookie)
 End If
 iCookie = strCookie(bNum)
 End If
 End If
 GetCookie = iCookie
 End Function

'' ============================================
 '' 按照指定的正则表达式返回字符
 '' ============================================
Function RegExpSearch(Patrn, Str, sType, Spacer)
 Dim RegEx, Match, Matches, RetStr, i
 i = 0
 Set RegEx = New RegExp
 RegEx.Pattern = Patrn
 RegEx.IgnoreCase = True
 RegEx.Global = True
 Set Matches = RegEx.Execute(Str)
 For Each Match In Matches
 i = i + 1
 If sType = 0 Then
 RetStr = RetStr & Match.Value
 If i < Matches.Count Then RetStr = RetStr & Spacer
 Else
 RetStr = RetStr & Match.Value
 If i < Matches.Count Then RetStr = RetStr & Spacer
 If sType = i Then Exit For
 End If
 Next
 RegExpSearch = RetStr
 End Function

''*****************************************************************
 '' function（私有）
 '' 作用：利用流保存文件
 ''*****************************************************************
Function SaveFiles(ByVal GetUrl, ByVal ToFile, ByVal sCookie, ByVal Agent, ByVal SaveShow)
 Dim Datas, dSize
 GetUrl = Replace(GetUrl, "/", "/")
 Datas = HttpGet(10000, 10000, 20000, 20000, "GET", GetUrl, "", "", sCookie, "zh-cn", "", Agent, "", "*/*", "")
 iSize = LenB(Datas)
 dSize = FormatNumber(iSize / 1024, 3)
 If iSize > 1 Then
 Set Ados = Server.CreateObject("ADODB.Stream")
 Ados.Type = 1
 Ados.Mode = 3
 Ados.Open
 Ados.Write Datas
 Ados.SaveToFile Server.MapPath(ToFile), 2
 Ados.Close
 Set Ados = Nothing
 SaveFiles = True
 If SaveShow = 1 Then
 Response.Write "保存成功：" & dSize & "Kb"
 End If
 Else
 SaveFiles = False
 If SaveShow = 1 Then
 Response.Write "保存失败：文件大小" & iSize & "K，小于1K"
 End If
 End If
 End Function
 '' ============================================
 '' 检测文件夹是否存在如果不存在就自动创建多级文件夹
 '' ============================================
Function CreatePath(strPath)
 Dim fldr, FristStr
 strPath = Replace(strPath, "/", "/")
 strPath = Replace(strPath, Chr(0), "")
 strPath = Replace(strPath, "//", "/")
 If Left(strPath, 1) = "/" Then
 FristStr = "/"
 strPath = Right(strPath, Len(strPath) - 1)
 Else
 FristStr = ""
 strPath = strPath
 End If
 If Right(strPath, 1) = "/" Then
 strPath = Left(strPath, Len(strPath) - 1)
 Else
 strPath = strPath
 End If
 GetNewsFold = Split(strPath, "/")
 fldr = ""
Set FSO = Server.CreateObject("Scripting.FileSystemObject")
 For i = 0 To UBound(GetNewsFold)
 If fldr = "" Then
 fldr = FristStr & GetNewsFold(i)
 Else
 fldr = fldr & "/" & GetNewsFold(i)
 End If
 If FSO.FolderExists(Server.MapPath(fldr)) = False Then
 Call FSO.CreateFolder(Server.MapPath(fldr))
 End If
 Next
Set FSO = Nothing
 If Err.Number = 0 Then
 Err.Clear
 CreatePath = Replace(fldr, "/", "/") & "/"
 Else
 CreatePath = ""
 End If
 End Function
 '' ============================================
 '' function（公有）
 '' 作用：保存文件，并自动创建多级文件夹
 '' ============================================
Function SaveData(FromUrl, ToFiles, sCookie, sAgent, SaveType, SaveShow)
 Dim strFile, NewPath
 strFile = Replace(ToFiles, "/", "/")
 strFile = Replace(strFile, Chr(0), "")
 strFile = Replace(strFile, "//", "/")
 NewPath = Mid(strFile, 1, InStrRev(strFile, "/"))
Set FSO = Server.CreateObject("Scripting.FileSystemObject")
 If FSO.FileExists(Server.MapPath(strFile)) = False Then
 If FSO.FolderExists(Server.MapPath(NewPath)) = False Then
 Call CreatePath(NewPath)
 End If
 SaveData = SaveFiles(FromUrl, strFile, sCookie, sAgent ,SaveShow)
 Else
 '' 覆盖文件
 If SaveType = 1 Then
 SaveData = SaveFiles(FromUrl, strFile, sCookie, sAgent ,SaveShow)
 Else
 SaveData = True
 End If
 End If
Set FSO = Nothing
 End Function
%>

下面是一个使用的例子：


<%
Dim DoGet
Dim sCookie
Dim sUserAgent

Set DoGet = New FlyCms_AspHttp

Rw "下载91f的文件 "
Down91f

Rw " 下载haoting的文件 "
DownHaoting

Set DoGet = Nothing

Sub Down91f()
''91f 欺骗身份

sCookie = ""
sUserAgent = "NSPlayer/9.0.0.2991 WMFSDK/9.0 " ''这句模拟Media Player身份
FromUrl = "http://202.101.235.99/mu/MP/@2AC6BFD79E8BA1E58860618CDD2CEEB14//f/71/2.Wma"
ToFiles = "33/2.wma"
Call SaveData(FromUrl, ToFiles, sCookie, sUserAgent, 1, 1)
End Sub

Sub DownHaoting()
''欺骗Cookie+欺骗身份

sUrl = "http://sy1.haoting.com/mpin" ''Cookie认证页面,我们可以从这里取得Cookie
TempStr = HttpGet(10000,10000,20000,20000,"GET",sUrl,"",sData,"","zh-cn","application/x-www-form-urlencoded","Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)","gzip, deflate","*/*","gb2312")
sCookie = GetCookie(DoGet.strHeaders,-1) ''这句用来取得上页面中的Cookie

sUserAgent = "NSPlayer/9.0.0.2991 WMFSDK/9.0 " ''这句模拟Media Player身份
FromUrl = "http://htst.haoting.com/ahn/a/adu/1/3.wma"
ToFiles = "33/3.wma"
Call SaveData(FromUrl, ToFiles, sCookie, sUserAgent, 1, 1)
End Sub