vbs模拟登陆、遍历，然后批量，调用迅雷下载某电影网站的资源

对 www.cool8.tv 的短篇资源爱不释手，所以写了个脚本把全部下载到本地了。

保存下列代码为 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

'程序完

'---------------公用函数-----------------

'读取真实视频地址
Function 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", " image/gif, image/x-xbitmap, image/jpeg, image/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", " www.cool8.tv"
xmlhttp.setRequestHeader "Connection", " Keep-Alive"
End Sub

'保存xmlHttp返回为文件，随便解码
Function 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提交
Function 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编码
Function 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

转载于:https://www.cnblogs.com/HappyQQ/archive/2008/02/26/1081443.html