对 [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
'交互登陆
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
