<% Server.ScriptTimeOut=9999999 function getHTTPPage(url) on error resume next dim http set Http=server.createobject("MSXML2.XMLHTTP") Http.open "GET",url,false Http.send() if Http.readystate<>4 then exit function end if getHTTPPage=Http.responseBody set http=nothing if err.number<>0 then err.Clear end function function saveimage(from,tofile) dim geturl,objStream,imgs geturl=trim(from) imgs=gethttppage(geturl)'取得图片的具休内容的过程 Set objStream = Server.CreateObject("ADODB.Stream") objStream.Type =1 objStream.Open objstream.write imgs objstream.SaveToFile server.mappath(tofile),2 objstream.Close() set objstream=nothing end function Set UpFileObj = New UpFile_Class UpFileObj.GetData(102400000000000000) AutoReName = "2" ClueOn_Msg = "" No_UpFileTF = True AppearErr = False dim geturl,bookid,lid,title,laiy,TP,idc title=UpFileObj.Form("title") laiy=UpFileObj.Form("laiy") geturls=UpFileObj.Form("geturls") idc=UpFileObj.Form("idc") bookid=UpFileObj.Form("bookid") TP=UpFileObj.Form("TP") lid=UpFileObj.Form("lid") Set FileObject = Nothing Set Fso = Nothing if geturls="" then Call Error("采集页面地址不能为空！") end if if lid="" or isnumeric(lid)=False then Call Error("请选择导入到的类别！") end if if bookid="" or isnumeric(bookid)=False then Call Error("请选择模板！") end if if instr(geturls,"http://")<=0 then Call Error("地址应该存在http://") end if set rs1=server.createobject("adodb.recordset") sql1="select * from cjbook where id= "&bookid rs1.open sql1,conn,1,1 if rs1.eof then Call Error("不存在的采集模板！") end if starwml=rs1("starwml") overwml=rs1("overwml") addurl=rs1("addurl") ubm=rs1("ubm") rs1.close set rs1=nothing if TP="" then if title="" then Call Error("各项都不能为空！") end if set rs1=server.CreateObject("adodb.recordset") sql1="select * from wjfile" rs1.open sql1,conn,1,3 Rs1.addnew Rs1("name")=title Rs1("times")=now() Rs1("lid")=lid Rs1("laiy")=laiy Rs1("typeID")=1 Rs1.Update Rs1.close Set Rs1=nothing set rs2=server.CreateObject("adodb.recordset") sql2="select top 1 id from wjfile order by id desc" rs2.open sql2,conn,1,1 idc=rs2("id") Rs2.close Set Rs2=nothing end if content=Gethtml(geturls,ubm) content=Getstr(content,starwml,overwml) Set objRegExp = New Regexp objRegExp.IgnoreCase = True objRegExp.Global = True objRegExp.Pattern = "" strs=trim(content) Set Matches =objRegExp.Execute(strs) For Each Match in Matches if RetStr<>"" Then RetStr = RetStr&"||"&left(Match.Value,len(Match.Value)) Else RetStr=Match.Value End if Next Arrimg=split(RetStr,"||") For Tempi=0 To Ubound(Arrimg) objRegExp.Pattern ="src\s*=\s*.+?\.(gif|jpg|bmp|jpeg|png|tiff)" Set Matches =objRegExp.Execute(Arrimg(Tempi)) For Each Match in Matches if TempStr<>"" Then TempStr=TempStr & "$Array$" & Match.Value Else TempStr=Match.Value End if Next Next If TempStr<>"" Then objRegExp.Pattern ="src\s*=\s*" TempStr=objRegExp.Replace(TempStr,"") End If TempStr=Replace(TempStr,"""","") TempStr=Replace(TempStr,"'","") TempStr=Replace(TempStr," ","") TempArray=Split(TempStr,"$Array$") For i=0 To UBound(TempArray) RANDOMIZE sjs=INT((99-00+1)*RND+00) picname=year(date)&month(date)&day(date)&hour(time())&minute(time())&second(time())&sjs if len(addurl)>7 then urls= addurl&TempArray(i) else urls= TempArray(i) end if ggss=right(urls,3) tofile="/pic/"&picname&"."&ggss saveimage urls,tofile set rs1=server.CreateObject("adodb.recordset") sql1="select * from uppic" rs1.open sql1,conn,1,3 Rs1.addnew Rs1("picurl")=tofile Rs1("lid")=idc Rs1.Update Rs1.close Set Rs1=nothing Next response.write"采集完成了" conn.close set conn=nothing %>
[继续为此组图片采集]
[查看图片]
[图片列表]
[图片类别]
[后台管理]