飞扬远程获取类Asp xmlHttp 源码（2）

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 "保存成功：<font color=red>" & dSize & "</font>Kb"
　　　　　　　　　　　　　　　 End If
　　　　　　　　　　　 Else
　　　　　　　　　　　　　　　 SaveFiles = False
　　　　　　　　　　　　　　　 If SaveShow = 1 Then
　　　　　　　　　　　　　　　　　　　　 Response.Write "保存失败：<font color=red>文件大小" & iSize & "K，小于1K</font>"
　　　　　　　　　　　　　　　 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
％>
下面是一个使用远程获取类获取自动采集下载音乐文件的例子：

<!-- #include file = "Cls_AspHttp.asp" -->
<!-- #include file = "Function.asp" -->
<％
　Dim DoGet
　Dim sCookie
　Dim sUserAgent
　Set DoGet = New FlyCms_AspHttp
　
　Rw "下载91f的文件<br>"
　Down91f
　Rw "<br>下载haoting的文件<br>"
　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 = "https://www.aspxhome.com/ahn/a/adu/1/3.wma"
　 ToFiles = "33/3.wma"
　 Call SaveData(fromUrl, ToFiles, sCookie, sUserAgent, 1, 1)
　End Sub
％>