編者注：這個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 "保存成功：<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 = "http://htst.haoting.com/ahn/a/adu/1/3.wma"
ToFiles = "33/3.wma"
Call SaveData(FromUrl, ToFiles, sCookie, sUserAgent, 1, 1)
End Sub
%>