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

it2025-03-20 19

对 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