优酷一键采集 测试

啊城

看看采集后的视频能用多长时不过期啊 美中不足，就是当采集和单首增加同时用，列表就排得乱七八糟 看以后有时间能不能再改善 asp版 采集程序开源，是否有朋友能转换成php版 如能记的发我参照一下为谢。 测试方法的地址；http://www.flashcs5as3.com/bfs/代理程序/youku采集.asp?id=http://v.youku.com/v_show/id_XMzc1MjIxODI0.html

2. <%
3. '说明 当 输入url目标网页地址，返回值getHTTPPage是目标网页的html代码
4. '跟随当前的 html代码 中找到相关的信息
5. '---------------------------------加载html代码 URL网址数据--------------------
6. function getHTTPPage(url) '定义函数
7. dim Http '定义变量http
8. set Http=server.createobject("MSXML2.XMLHTTP")'建立XMLHTTP对象
9. Http.open "GET",url,false '设置http对象打开方式 GET方式， URL 连接页面地址，同步处理
10. Http.send() '发送请求
11. if Http.readystate<>4 then '对象处理状态为 非结束
12. exit function '退出函数
13. end if
14. getHTTPPage=bytesToBSTR(Http.responseBody,"utf-8") '接收数据并转换 文本格式 utf-8 也可以用 GB2312
15. set http=nothing
16. if err.number<>0 then err.Clear '错误代码非0则出错 清除错误
17. end function ''退出定义函数
18. '------------------------------------转换html代码数据---------------------------
19. '转换乱玛，直接用xmlhttp调用有中文字符的网页得到的将是乱玛，可以通过adodb.stream组件进行转换
20. Function BytesToBstr(body,Cset)
21. dim objstream
22. set objstream = Server.CreateObject("adodb.stream")
23. objstream.Type = 1
24. objstream.Mode =3
25. objstream.Open
26. objstream.Write body
27. objstream.Position = 0
28. objstream.Type = 2
29. objstream.Charset = Cset
30. BytesToBstr = objstream.ReadText
31. objstream.Close
32. set objstream = nothing
33. End Function
34. '------------------------------------强制数据----------------------------------
35. '强制函数相 当无法得到 html代码时
36. '进行强制性来得到 url目标网页地址所有的代码
37. Function GetKey(HTML,Start,Last)
38. Dim filearray,filearray2
39. filearray=split(lcase(HTML),lcase(Start))
40. filearray2=split(lcase(filearray(1)),lcase(Last))
41. GetKey=filearray2(0)
42. End Function
44. '------------------------------------输入url网页地址---------------------------
45. '连接 ID 的信息
46. Dim Url,Html '定义2个变量 Url Html
47. Url=request.querystring("id")'设为 ?id= 后面的网址信息
48. Html = getHTTPPage(Url)
49. '输出当前要采集的 标题名称
50. 'Response.write "当前采集的的标题名是："&GetKey(Html,"<title>","</title>")
53. '--------------------------防止别的域名连接使用-------------------
54. 'dim iphtmlUrl,strURid,aryReturnm
55. 'iphtmlUrl ="http://"&Request.ServerVariables("SERVER_NAME") & Request.ServerVariables("URL")
56. 'strURid = iphtmlUrl 'http://www.flashcs5as3.com/bfs/代理程序/
57. 'aryReturnm = Split(strURid,"flashcs5as3")
58. 'if aryReturnm then
59. ' call ponseList1()
60. 'else
61. 'call ponseList2()
62. 'end if
64. 'sub ponseList1()
65. 'response.Redirect("http://www.flashcs5as3.com")
66. 'end sub
68. 'sub ponseList2()
69. 'response.Redirect("ok本站使用")
70. 'end sub
72. '----------------------------------生成xml 数据-------------------
73. dim body,jmStr,tvName,tvTitle
74. dim i
75. flag = instr(Html,"<ul class=""pack_number"">")'设置 flag 变量名 从html代码中到到相关的位置 开始位置
76. jmStr = mid(Html,flag,instr(flag,Html,"</ul>")-flag)'结束的位置
77. 'response.write(jmStr)' '输出相关内容
78. bfsxml = bfsxml & "<?xml version='1.0' encoding='gb2312'?>" & vbcrlf &"<list>" &""'设置XML 的编码 方便FLASH中读入
79. a = 0
80. for i = 1 to len(jmStr)'进行计算 输出 XML 的ID
81. if mid(jmStr,i,3) = "d=""" then
82. tvName = mid(jmStr,i+3,instr(i+3,jmStr,""">")-i-3)
83. Session("tvTitle") = Session("tvTitle") & tvName & vbcrlf
84. a = a + 1
85. bfsxml = bfsxml & "<m label=""" & tvName & """ />" & vbcrlf
86. 'bfsxml = bfsxml & "<m> "&"<n>""" & tvName & """ <n> "&"<m/>" & vbcrlf
87. end if
88. next
89. bfsxml = bfsxml & vbcrlf & "</list>"
90. response.write(bfsxml)'输出bfsxml 输出播放器需要加载的XML
91. %>

复制代码

梵音未改

啊城的作品一定是高难新颖的。辛苦了

清音王梓

阿城是代码达人啊，我看到这一堆代码就头大，哈哈！强人！{:soso_e179:}