<% server.scripttimeout=99999 const gatherWaitTime=3 '采集每页数据间隔时间 Dim gbTypeArray,backurl:backurl=getForm("backurl","get") Dim ac,h,wd,rid,t,pg:ac=getForm("ac","both"):h=getForm("h","both"):wd=getForm("wd","both"):rid=getForm("rid","both"):t=getForm("t","both"):pg=getForm("pg","both") Dim url,cjurl:cjurl=getForm("url", "both") Dim url2, url3, cjHost redim res(2,-1) if not isNum(pg) then pg=1 else pg=Clng(pg) end if if not isNum(t) then t=0 else t=Clng(t) end if 'API AddResUrl -1,"","

请把图片下载到本地,以免杜绝日后出现类似图片失效的情况。

" AddResUrl 1,"http://192.168.2.153:21003/cjapi/as/max/vod/xml","海淘资源网稳定、快速、更新及时---推荐" AddResUrl 2,"http://192.168.2.153:21003/cjapi/as/max/vod/xml/m3u8","【海淘资源网-M3U8资源】稳定、快速、更新及时---推荐" AddResUrl 3,"http://192.168.2.153:21003/cjapi/as/max/vod/xml/iframe","【海淘资源网-云资源】稳定、快速、更新及时---推荐" Header Select Case ac Case "list":getlist() Case "bind":bindType Case "bindsubmit":bindSubmit case "select":gather Case "type":gatherType Case "day":gatherDay Case "all":gatherALl Case else Main End Select Footer terminateAllObjects Function rNodeText(ByRef node,ByVal name) rNodeText=Replace(node.selectNodes(name)(0).text,"<","<") End Function Function filterQuote(ByVal s) filterQuote=ReplaceStr(s,"'","") End Function Function U2UTF8(Byval a_iNum) Dim sResult,sUTF8,iTemp,iHexNum,i:iHexNum = Clng(a_iNum) If iHexNum = 0 Then Exit Function sResult = "" If (iHexNum < 128) Then sResult = "%" & hex(iHexNum) ElseIf (iHexNum < 2048) Then sResult = "%" & hex(&H80 + (iHexNum And &H3F)) iHexNum = iHexNum \ &H40 sResult = "%" & hex(&HC0 + (iHexNum And &H1F)) & sResult ElseIf (iHexNum < 65536) Then sResult = "%" & hex(&H80 + (iHexNum And &H3F)) iHexNum = iHexNum \ &H40 sResult = "%" & hex(&H80 + (iHexNum And &H3F)) & sResult iHexNum = iHexNum \ &H40 sResult = "%" & hex(&HE0 + (iHexNum And &HF)) & sResult End If U2UTF8 = sResult End Function Function Utf8UrlEncode(Byval sStr) Dim sGB,sResult,sTemp Dim iLen,iUnicode,iTemp,i:sGB = sStr:iLen = Len(sGB) For i = 1 To iLen sTemp = Mid(sGB,i,1):iTemp = Asc(sTemp) If (iTemp>127 OR iTemp<0) Then iUnicode = AscW(sTemp) If iUnicode<0 Then iUnicode = iUnicode + 65536 End If Else iUnicode = iTemp End If sResult = sResult & U2UTF8(iUnicode) Next Utf8UrlEncode = sResult End Function Function makePageNumber(Byval currentPage,Byval pageListLen,Byval totalPages) currentPage=clng(currentPage) dim beforePages,pagenumber,page dim beginPage,endPage,strPageNumber if pageListLen mod 2=0 then beforePages=pagelistLen / 2 else beforePages=clng(pagelistLen / 2) - 1 if currentPage < 1 then currentPage=1 else if currentPage > totalPages then currentPage=totalPages if pageListLen > totalPages then pageListLen=totalPages if currentPage - beforePages < 1 then beginPage=1 : endPage=pageListLen elseif currentPage - beforePages + pageListLen > totalPages then beginPage=totalPages - pageListLen + 1 : endPage=totalPages else beginPage=currentPage - beforePages : endPage=currentPage - beforePages + pageListLen - 1 end if for pagenumber=beginPage to endPage if pagenumber=1 then page="" else page=pagenumber if clng(pagenumber)=clng(currentPage) then strPageNumber=strPageNumber&""&pagenumber&"" else strPageNumber=strPageNumber&""&pagenumber&"" end if next makePageNumber=strPageNumber End Function Sub getlist() Dim xmlobj,xml,nodes,i,l,tlist,pagestr,x,y,z,url:set xmlobj = mainClassobj.createObject("MainClass.Xml") url=res(1,rid)&"?ac=list&t="&t&"&h="&h&"&pg="&pg&"&wd="&Utf8UrlEncode(wd) If cjurl <>"" Then url2=split(cjurl, "?") url3=split(url, "?") url = url2(0)&"?"&url3(1) url=cjurl&"?ac=list&t="&t&"&h="&h&"&pg="&pg&"&wd="&Utf8UrlEncode(wd) cjHost = url2(0) End If xml=bytesToStr(getRemoteContent(url,"body"),"utf-8") If left(xml, 5) <> "
共 "&recordcount&" 条数据 每页 "&pagesize&" 条 当前 "&page&"/"&pagecount&" 页码" pagestr = pagestr & "首页上一页" pagestr = pagestr & makePageNumber(page,10,pagecount) pagestr = pagestr & "下一页尾页" pagestr = pagestr & "  跳转  
" %> <% dim la,id,ti,na,ty,dt,no,ch:set nodes=xmlobj.getNodes("rss/list/video"):l=nodes.length-1 for i=0 to l la=rNodeText(nodes(i),"last") id=rNodeText(nodes(i),"id") ti=rNodeText(nodes(i),"tid") na=rNodeText(nodes(i),"name") ty=rNodeText(nodes(i),"type") dt=rNodeText(nodes(i),"dt") no=rNodeText(nodes(i),"note") ch="" if isDate(la) then if DateValue(la)=Date() then ch=" checked":la=""&la&"" end if %> <% next %>
 采集平台 » <%=res(2,rid)%>
    <% echo "
  • 全部
  • " for i=0 to UBound(tlist,2) z = res(0,rid)&"_"&tlist(0,i) y = getBindedLocalId(z):if not isNum(y) then y=0 if y = 0 then x = "[未绑定]" else x = "[已绑定]" end if echo "
  • "&tlist(1,i)&"  " & x & "
  • " next %>
<%=pagestr%>
       />     查询:    
名称 分类 来源 时间
/> <%=ty%> <%=dt%> <%=la%>
<%=pagestr%>
<% set nodes=nothing:set xmlobj=nothing End Sub Sub Main %>
 采集平台
<% dim i for i=0 to UBound(res,2) if res(0,i)=-1 then %> <% else %> <% end if next %>
<%=res(2,i)%>
(<%=right("00"&res(0,i),2)%>)<%=res(2,i)%> 采集当天 一键采集所有 视频列表
<% End Sub Sub Header checkPower %> 采集平台
<% End Sub Sub Footer %>
<%echoRunTime%>
Copyright 2005-2009 All rights reserved. Maxcms4.0
<% End Sub Sub bindType dim bind_back,vtypename,curBindId,typeid,operType:bind_back=getRefer vtypename=getForm("tname","get"):curBindId=getForm("curid","get"):operType=getForm("class","get") %>
 采集平台 » 绑定分类
<% echo "
将分类 "&vtypename&" 绑定到您的网站分类的      
" %>
<% End Sub Sub bindSubmit dim bind_back,curBindId,operType,m_type,rsobj,m_oldtype curBindId=getForm("curid","get"):operType=getForm("class","get") m_type=getForm("m_type","post"):bind_back=getForm("bind_back","post"):m_oldtype=getForm("m_oldtype","post") if isNum(m_type) then if not isNul(m_oldtype) then set rsobj=conn.db("select m_unionid from {pre}type where m_id="&m_oldtype,"records3") if not rsobj.eof then rsobj("m_unionid")=delBindId(curBindId,rsobj("m_unionid")) rsobj.update end if rsobj.close:set rsobj=nothing end if set rsobj=conn.db("select m_unionid from {pre}type where m_id="&m_type,"records3") if not rsobj.eof then rsobj("m_unionid")=addUnionid(curBindId,rsobj("m_unionid")) rsobj.update end if rsobj.close:set rsobj=nothing alertMsg "绑定成功",bind_back else set rsobj=conn.db("select m_unionid from {pre}type where ','+m_unionid+',' like '%,"&curBindId&",%'","records3") if not rsobj.eof then rsobj("m_unionid")=delBindId(curBindId,rsobj("m_unionid")) rsobj.update end if rsobj.close:set rsobj=nothing alertMsg "解除绑定",bind_back end if End Sub Function delBindId(bindid,unionId) if isNul(unionId) then delBindId=unionId else if instr(","&unionId&",",","&bindid&",")>0 then delBindId=trimOuterStr(replace(","&unionId&",",","&bindid&",",","),",") else addUnionid=unionId end if End Function Function addUnionid(bindid,unionId) if isNul(unionId) then addUnionid=bindid else if instr(","&unionId&",",","&bindid&",")>0 then addUnionid=unionId else addUnionid=unionId&","&bindid end if End Function Function getBindedLibIds() dim libIds,i,arrayLen if not isarray(gbTypeArray) then gbTypeArray=conn.db("select m_id,m_unionid from {pre}type where m_type=0 AND len(m_unionid)>0","array") end if if isArray(gbTypeArray) then arrayLen=ubound(gbTypeArray,2) for i=0 to arrayLen if i0","array") end if if not isArray(gbTypeArray) then getBindedLocalId="" : Exit Function arrayLen=ubound(gbTypeArray,2) for i=0 to arrayLen unionArray=split(gbTypeArray(1,i),",") : arrayLen2=ubound(unionArray) for j=0 to arrayLen2 if trim(unionArray(j))=trim(libId) then getBindedLocalId=gbTypeArray(0,i) : Exit Function next next getBindedLocalId="" End Function Sub gather dim weburl,ids:ids=replace(getForm("ids","both"),", ",",") if isNul(ids) then alertMsg "请选择采集数据","":last weburl=res(1,Clng(rid))&"?ac=videolist&ids="&ids If cjurl <>"" Then weburl=cjurl&"?ac=videolist&ids="&ids intoDatabase weburl,"select" End Sub Sub gatherType dim weburl:weburl=res(1,Clng(rid))&"?ac=videolist&rid="&rid&"&t="&t&"&pg="&pg If cjurl <>"" Then weburl=cjurl&"?ac=videolist&rid="&rid&"&t="&t&"&pg="&pg intoDatabase weburl,"type" End Sub Sub gatherDay dim weburl:weburl=res(1,Clng(rid))&"?ac=videolist&rid="&rid&"&t="&t&"&h=24&pg="&pg If cjurl <>"" Then weburl=cjurl&"?ac=videolist&rid="&rid&"&t="&t&"&h=24&pg="&pg intoDatabase weburl,"day" End Sub Sub gatherAll dim weburl:weburl=res(1,Clng(rid))&"?ac=videolist&rid="&rid&"&pg="&pg If cjurl <>"" Then weburl=cjurl&"?ac=videolist&rid="&rid&"&pg="&pg intoDatabase weburl,"type" End Sub Function repairStr(ByVal vstr,ByVal sfrom) dim regExpObj : set regExpObj= new RegExp : regExpObj.ignoreCase = true : regExpObj.Global = true : regExpObj.Pattern = "[\s\S]+?\$[\s\S]+?\$[\s\S]+?" dim i,j,f: j=1 if sfrom="baidu" then sfrom="百度影音" elseif sfrom="tudou" then sfrom="土豆" elseif sfrom="qiyi" then sfrom="奇艺" elseif sfrom="youku" then sfrom="优酷" end if vstr = split(vstr,"#"):f=getReferedId(sfrom) for i = 0 to ubound(vstr) if not(isnul(vstr(i))) then if regExpObj.Test(vstr(i)) = false then regExpObj.Pattern = "[\s\S]+?\$[\s\S]+?" if regExpObj.Test(vstr(i)) = true then vstr(i) = trim(vstr(i))&"$"&f else vstr(i)="第"&j&"集$"&trim(vstr(i))&"$"&f end if regExpObj.Pattern = "[\s\S]+?\$[\s\S]+?\$[\s\S]+?" else vstr(i) = trim(vstr(i)) end if j=j+1 end if next repairStr = sfrom&"$$"&Join(vstr,"#") set regExpObj =nothing End Function Sub intoDatabase(url,gtype) dim xmlobj,xml,alertContent,vtype,vNodes,i,m_playdata,pagecount,page,j,l,childNodes:pagecount=0:page=pg set xmlobj = mainClassobj.createObject("MainClass.Xml") echo "
视频采集开始:"&cjHost&"
" xml=bytesToStr(getRemoteContent(url,"body"),"utf-8") If left(xml, 5) <> "115 then title=getStrByLen(title,115) pic=filterQuote(vNodes(i).childNodes(5).text) des=filterQuote(vNodes(i).childNodes(14).text) m_lang=filterQuote(vNodes(i).childNodes(6).text) if computeStrLen(m_lang)>30 then m_lang=getStrByLen(m_lang,30) publisharea=filterQuote(vNodes(i).childNodes(7).text) if computeStrLen(publisharea)>30 then publisharea=getStrByLen(publisharea,30) publishyear=vNodes(i).childNodes(8).text states=vNodes(i).childNodes(9).text m_note=filterQuote(vNodes(i).childNodes(10).text) actor=replaceStr(trim(filterQuote(vNodes(i).childNodes(11).text))," ",",") if computeStrLen(actor)>250 then actor=getStrByLen(actor,250) director=replaceStr(filterQuote(vNodes(i).childNodes(12).text)," ",",") if computeStrLen(director)>40 then director=getStrByLen(director,40) if not isNum(publishyear) then publishyear=0 if not isNum(states) then states=0 localId=getBindedLocalId(libid) if not isNul(title) then title=replace(replace(title,"[","["),"]","]") if isNum(localId) then titleArray=split(title,"/") if UBound(titleArray)>-1 then title=titleArray(0) for m_i=0 to ubound(titleArray) if not isNul(titleArray(m_i)) then m_where=m_where&" or '/'+m_name+'/' like '%/"&titleArray(m_i)&"/%' " next m_where=trimOuterStr(m_where," or") m_sql="select top 1 m_id,m_playdata from {pre}data where "&m_where set vrsObj=conn.db(m_sql,"execute") if vrsObj.eof then m_enname=MoviePinYin(title):sql="insert into {pre}data(m_name,m_type,m_state,m_pic,m_actor,m_des,m_playdata,m_isunion,m_publishyear,m_publisharea,m_note,m_letter,m_enname,m_director,m_lang) values('"&title&"',"&localId&","&states&",'"&pic&"','"&actor&"','"&des&"','"&vid&"',1,"&publishyear&",'"&publisharea&"','"&m_note&"','"&Left(m_enname,1)&"','"&m_enname&"','"&director&"','"&m_lang&"')" else select case gatherSet case 0,1,2,3 m_playdata = gatherIntoLibTransfer(vrsObj("m_playdata"),vid,gatherSet) sql="update {pre}data set m_state="&states&ifthen(isSpecial(vtype),",m_note='"&m_note&"'","")&",m_lang='"&m_lang&"',m_playdata='"&m_playdata&"',m_isunion=1,m_addtime='"&now()&"' where m_id="&vrsObj("m_id") case 4 m_enname=MoviePinYin(title):sql="insert into {pre}data(m_name,m_type,m_state,m_pic,m_actor,m_des,m_playdata,m_isunion,m_publishyear,m_publisharea,m_note,m_letter,m_enname,m_director,m_lang) values('"&title&"',"&localId&","&states&",'"&pic&"','"&actor&"','"&des&"','"&vid&"',1,"&publishyear&",'"&publisharea&"','"&m_note&"','"&Left(m_enname,1)&"','"&m_enname&"','"&director&"','"&m_lang&"')" case 5 sql="update {pre}data set m_actor='"&actor&"',m_director='"&director&"',m_lang='"&m_lang&"',m_pic='"&pic&"',m_des='"&des&"',m_publishyear="&publishyear&ifthen(isSpecial(vtype),",m_note='"&m_note&"'","")&",m_publisharea='"&publisharea&"',m_addtime='"&now()&"' where m_id="&vrsObj("m_id") end select end if vrsObj.close : set vrsObj=nothing conn.db sql,"execute" 'echo "OK
" else libid=000000 titleArray=split(title,"/") if UBound(titleArray)>-1 then title=titleArray(0) for m_i=0 to ubound(titleArray) if not isNul(titleArray(m_i)) then m_where=m_where&" or '/'+m_name+'/' like '%/"&titleArray(m_i)&"/%' " next m_where=trimOuterStr(m_where," or") m_sql="select top 1 m_id,m_playdata from {pre}temp where "&m_where set vrsObj2=conn.db(m_sql,"execute") if vrsObj2.eof then 'pic=gatherPicHandle(pic,title) sql="insert into {pre}temp(m_name,m_type,m_state,m_pic,m_actor,m_des,m_playdata,m_publishyear,m_publisharea,m_director,m_lang) values('"&title&"',"&libid&","&states&",'"&pic&"','"&actor&"','"&des&"','"&vid&"',"&publishyear&",'"&publisharea&"','"&director&"','"&m_lang&"')" else select case gatherSet case 0,1,2,3 m_playdata = gatherIntoLibTransfer(vrsObj2("m_playdata"),vid,gatherSet) sql="update {pre}temp set m_name='"&title&"',m_state="&states&",m_lang='"&m_lang&"',m_playdata='"&m_playdata&"',m_addtime='"&now()&"' where m_id="&vrsObj2("m_id") case 4 'pic=gatherPicHandle(pic,title) sql="insert into {pre}temp(m_name,m_type,m_state,m_pic,m_actor,m_des,m_playdata,m_publishyear,m_publisharea,m_director,m_lang) values('"&title&"',"&libid&","&states&",'"&pic&"','"&actor&"','"&des&"','"&vid&"',"&publishyear&",'"&publisharea&"','"&director&"','"&m_lang&"')" case 5 'pic=gatherPicHandle(pic,title) sql="update {pre}temp set m_pic='"&pic&"',m_actor='"&actor&"',m_director='"&director&"',m_lang='"&m_lang&"',m_des='"&des&"',m_publishyear="&publishyear&",m_publisharea='"&publisharea&"',m_addtime='"&now()&"' where m_id="&vrsObj2("m_id") end select end if vrsObj2.close : set vrsObj2=nothing conn.db sql,"execute" end if end if echo "数据"&title&"已经采集成功
" Next set xmlobj = nothing if page暂停"&gatherWaitTime&"秒--即将开始同步第"&page&"/"&pagecount&"页
" if gtype="day" Then echo "" elseif gtype="type" then echo "" end if else if gtype="select" then die "" else die "" end if end if End Sub Sub AddResUrl(ByVal rid,ByVal sUrl,ByVal sTxt) on Error resume next Dim l:l=UBound(res,2)+1:l=ifthen(err.number>0,0,l):ReDim Preserve res(2,l) res(0,l)=rid:res(1,l)=sUrl:res(2,l)=sTxt End Sub Function getRemoteContent(Byval url,Byval returnType) if not isObject(gXmlHttpObj) then:set gXmlHttpObj=tryXmlHttp():end if gXmlHttpObj.open "GET",url,False gXmlHttpObj.send() select case returnType case "text" getRemoteContent=gXmlHttpObj.responseText case "body" getRemoteContent=gXmlHttpObj.responseBody end select End Function Function FilterChar(ByVal Text) dim i for i=1 to &H1F if i<>10 AND i<>13 then Text=Replace(Text,Chr(i),"") next FilterChar=Text End Function Function ifthen(ByVal Bo,ByVal v1,ByVal v2) if Bo=true then ifthen=v1 else ifthen=v2 end if End Function Function isSpecial(ByVal sType) isSpecial=false if Instr(sType,"剧")>2 then isSpecial=true elseif Instr(sType,"动漫")>0 then isSpecial=true elseif Instr(sType,"动画")>0 then isSpecial=true elseif Instr(sType,"综艺")>0 then isSpecial=true end if End Function %>