這個class主要用于操作asp中的xmlhttp。

首先是類定義 Cls_AspHttp.asp：
<%
''=================================================================
''飛揚(yáng)遠(yuǎn)程獲取類(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 '' 發(fā)送數(shù)據(jù)的超時時間,30秒
slreceiveTimeout = 30000 '' 接收response的超時時間,30秒
End Sub

'' ============================================
'' 返回版本信息
'' ============================================
Public Property Get Version
Version = "飛揚(yáng)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
'' ============================================
'' 發(fā)送數(shù)據(jù)的超時時間
'' ============================================
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
'' ============================================
'' 發(fā)送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
'' ============================================
'' 建立數(shù)據(jù)傳送對向!
'' ============================================
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
'' ============================================
'' 發(fā)送數(shù)據(jù)并取回遠(yuǎn)程數(shù)據(jù)
'' ============================================
Public Function HttpGet()
Dim sReturn
With oXml
.setTimeouts slresolveTimeout,slconnectTimeout,slsendTimeout,slreceiveTimeout
.Open sMethod,sUrl,False
If sSetCookie<>"" Then
.setRequestHeader "Cookie", sSetCookie ''設(shè)定Cookie
End If
If sReferer<>"" Then
.setRequestHeader "Referer", sReferer ''設(shè)定頁面來源
Else
.setRequestHeader "Referer", sUrl
End If
If sLanguage<>"" Then
.setRequestHeader "Accept-Language", sLanguage ''設(shè)定語言
End If
.setRequestHeader "Content-Length",Len(sData) ''設(shè)定數(shù)據(jù)長度
If sCONTENT<>"" Then
.setRequestHeader "CONTENT-Type",sCONTENT ''設(shè)定接受數(shù)據(jù)類型
End If
If sAgent<>"" Then
.setRequestHeader "User-Agent", sAgent ''設(shè)定瀏覽器
End If
If sEncoding<>"" Then
.setRequestHeader "Accept-Encoding", sEncoding ''設(shè)定gzip壓縮
End If
If sAccept<>"" Then
.setRequestHeader "Accept", sAccept ''文檔類型
End If
.Send sData ''發(fā)送數(shù)據(jù)
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
'' ============================================
'' 處理二進(jìn)制數(shù)據(jù)
'' ============================================
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 調(diào)用的代碼： （簡化了代碼的書寫）
<%
''調(diào)試代碼
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

'' ============================================
'' 按照指定的正則表達(dá)式返回字符
'' ============================================
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 "保存失?。?lt;font color=red>文件大小" & iSize & "K，小于1K</font>"
End If
End If
End Function
'' ============================================
'' 檢測文件夾是否存在 如果不存在就自動創(chuàng)建多級文件夾
'' ============================================
Function CreatePath(strPath)
Dim fldr, FristStr
strPath = Replace(strPath, "\", "/")
strPath = Replace(strPath, Chr(0), "")
strPath = Replace(strPath, "http://", "/")
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（公有）
'' 作用 ：保存文件，并自動創(chuàng)建多級文件夾
'' ============================================
Function SaveData(FromUrl, ToFiles, sCookie, sAgent, SaveType, SaveShow)
Dim strFile, NewPath
strFile = Replace(ToFiles, "\", "/")
strFile = Replace(strFile, Chr(0), "")
strFile = Replace(strFile, "http://", "/")
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