vbs模擬登錄、遍歷，而後批量，調用迅雷下載某電影網站的資源

對 [url]www.cool8.tv[/url] 的短篇資源愛不釋手，因此寫了個腳本把所有下載到本地了。

保存下列代碼爲 GetCool9.vbs，雙擊運行便可，可能會產生不少臨時文件

On Error Resume Next

'交互登錄
sUserName = InputBox( "Cool8 user name:",sTitle, "netunion")
If sUserName ="" then WScript.Quit
sUserPwd = InputBox( "Cool8 user password:",sTitle, "netunion")
If sUserPwd ="" Then WScript.Quit
sUploadPath =InputBox( "Where to save the download?:",sTitle,"I:\Upload\Cool8短片\")
If sUploadPath ="" Then WScript.Quit


sCool8Entry = "http://www.cool8.tv/humor/index.do?method=showPage&CHANNEL_ID=268" '登錄入口
sCool8Login = "CHANNEL_ID=268&actionURL=http%3A%2F%2Fwww.cool8.tv%2Fhumor%2Findex.do&operator.loginname="& sUserName& "&operator.passwd="& sUserPwd & "&cookieTimes=0" '登陸提交內容
sCoo8Pager1 = "cookieTimes=0&CHANNEL_ID=268&operator.loginname="& sUserName & "&actionURL=http%3A%2F%2Fwww.cool8.tv%2Fhumor%2Findex.do&operator.passwd="& sUserPwd & "&currPageNum=" '逐頁瀏覽
sCoo8Pager2 = "&goPageNum="
sReferUrl = "http://www.cool8.tv/humor/index.do?method=login" '下載引用頁

'獲得當前目錄sCurrDir
Set fso=CreateObject( "scripting.filesystemobject")
set ofile =fso.GetFile(WScript.ScriptFullName)
sCurrDir= ofile.ParentFolder
Set fso= Nothing

'全局的HTTP操做對象
Set xmlHttp = CreateObject( "Microsoft.XMLHTTP")
Set XunLei =CreateObject( "ThunderAgent.Agent")

'得到 cool8 的入口
xmlHttp.open "GET",sCool8Entry, False
xmlHttp.send
wscript.Echo xmlHttp.getAllResponseHeaders

'登陸(其實不用登陸的)
SimplePost "http://www.cool8.tv/humor/index.do?method=login",sCool8Login
SaveToFile xmlHttp.responseBody, "loginResult.htm"


For pi = 21 To 38 '後面那個是頁數
    
'逐頁打開
SimplePost "http://www.cool8.tv/humor/index.do?method=login",sCoo8Pager1 & pi & sCoo8Pager2
SaveToFile xmlHttp.responseBody, "list" & pi & ".htm"
    
'得到當前頁面的視頻頁面連接列表
Set oDOM=GetObject(sCurrDir & "\list" & pi & ".htm", "htmlfile")
WScript.Sleep 1000
Set ListForm = oDOM.getElementsByTagName( "table")(34) '列表所在的<table>位於html的第34位
    
For ti = 2 To ListForm.rows.length -3 '那個 2 是我一個小時調試的心血啊～～
     Set ThisCell=ListForm.rows(ti).cells(1)
    sFilmTitle=ThisCell.innerText
    sFilmLink= "http://www.cool8.tv/" & mid( CStr(ThisCell.all(1).getAttribute( "href")),18)
    
     '得到真實地址
    xmlHttp.open "GET",sFilmLink, False
    xmlHttp.send
    SaveToFile xmlHttp.responseBody, "detail"&(pi-1)*39+ti& ".htm"
    sVideoUrl=GetVideoUrl(sCurrDir & "\detail"&(pi-1)*39+ti& ".htm")
    
     '調用迅雷下載
    XunLei.AddTask sVideoUrl,sFilmTitle & ".wma",sUploadPath,"",sReferUrl
    
Next    
    
'完成一頁的分析後批量下載
XunLei.CommitTasks
Next

'程序完


'---------------公用函數-----------------

'讀取真實視頻地址
GetVideoUrl() GetVideoUrl(sHtmlFilePath)
Set tmpDOM=GetObject(sHtmlFilePath, "htmlfile")
WScript.Sleep 1000
GetVideoUrl = CStr(    tmpDOM.getElementsByTagName( "param")(14).getAttribute( "value"))
End Function


'贊成設置通常性HTTP請求頭(cool8備用)
Sub SetNormalHeaders
xmlhttp.setRequestHeader "Accept", " p_w_picpath/gif, p_w_picpath/x-xbitmap, p_w_picpath/jpeg, p_w_picpath/pjpeg, application/x-shockwave-flash, application/vnd.ms-excel, application/vnd.ms-powerpoint, application/msword, */*"
xmlhttp.setRequestHeader "Accept-Language", " zh-cn"
xmlhttp.setRequestHeader "Accept-Encoding", " gzip, deflate"
xmlhttp.setRequestHeader "User-Agent", " Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; Maxthon; .NET CLR 1.1.4322; .NET CLR 2.0.50727)"
xmlhttp.setRequestHeader "Host", " [url]www.cool8.tv[/url]"
xmlhttp.setRequestHeader "Connection", " Keep-Alive"
End Sub

'保存xmlHttp返回爲文件，隨便解碼
SaveToFile() SaveToFile(oResponseBody, sFileName)
Set oStream = CreateObject( "ADODB.Stream")    
oStream.Mode = 3    
oStream.Type = 1    
oStream.Open()    
oStream.Write(oResponseBody)    
oStream.SaveToFile sFileName,2    
Set oStream = Nothing
End Function

'簡單POST提交
SimplePost() SimplePost(sActionUrl,sSend)
xmlHttp.open "POST",sActionUrl, False
xmlHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
xmlHttp.setRequestHeader "Content-Length", Len(sSend)
xmlHttp.send(sSend)
End Function

'中文的UTF-8編碼
URLEncoding() URLEncoding(vstrIn)
        strReturn = ""
         For iv = 1 To Len(vstrIn)
                ThisChr = Mid(vStrIn,iv,1)
                 If Abs(Asc(ThisChr)) < &HFF Then
                 Select Case ThisChr                    
                 Case ":" strReturn = strReturn & "%3A"
                 Case "/" strReturn = strReturn & "%2F"
                 Case ";" strReturn = strReturn & "%3B"
                 Case "?" strReturn = strReturn & "%3F"
                         Case Else strReturn = strReturn & ThisChr
                         End Select
                 Else
                        innerCode = Asc(ThisChr)
                         If innerCode < 0 Then
                                innerCode = innerCode + &H10000
                         End If
                        Hight8 = (innerCode     And &HFF00)\ &HFF
                        Low8 = innerCode And &HFF
                        strReturn = strReturn & "%" & Hex(Hight8) &     "%" & Hex(Low8)
                 End If
         Next
        URLEncoding = strReturn
End Function