admin_collectionfast.asp

淘客网上商店网站程序 淘客网上商店网站程序 淘客网上商店网站程序

<!--#include file="Inc/Const.asp"-->
<!--#include file="../Inc/Cl_ClsCollect.asp"-->
<!--#include file="../Inc/Cl_Function_Collect.asp"-->
<%
'========================================
'	Edit by GDWneo
'	Last modify at 9:22 2007-9-6
'========================================
Server.ScriptTimeOut=99999
Dim Action,CollecType,ModuleName
Dim myCache
Dim ItemNum,ListNum,PaingNum,NewsSuccesNum,NewsFalseNum,NewsNum_i,Itemon,ItemIdstr,Itemok
Dim RsItem,SqlItem,ItemEnd,ListEnd
Dim PicUrls_i,NewsUrlPaing_s,NewsUrlPaing_o,NewsPaingNext_Code,TypeArray_Url,TypeNews_Url

'项目变量
Dim ItemID,ItemName,ChannelDir,ClassID,SpecialID,LoginType,LoginUrl,LoginPostUrl,LoginUser,LoginPass,LoginFalse
Dim ListStr,LsString,LoString,ListPaingType,LPsString,LPoString,ListPaingStr1,ListPaingStr2,ListPaingID1,ListPaingID2,ListPaingStr3,HsString,HoString,HttpUrlType,HttpUrlStr,photourls,photourlo,PhotoPaingType,PhotoType_s,PhotoType_o,PhotoLurl_s,PhotoLurl_o,Phototypefy_s,Phototypefy_o,Phototypefyurl_s,Phototypefyurl_o,Phototypeurl_s,Phototypeurl_o,Encoding,SaveFileUrl,x_tpUrl,Thumb_WaterMark,Thumbs_Create,Timing,strReplace

'下载变量
dim DownSize,SoftLanguage,CopyrightType,OperatingSystem,DemoUrl,AuthorHomepage,PhotoUrl,DownUrls
'下载变量项目字段
dim Downlist_s,Downlist_o,DownUrl_s,DownUrl_o,DownNewType,DownNewlist_s,DownNewlist_o,DownNewUrl_s,DownNewUrl_o,LinkUrlYn
dim ZdType_001,Zds_001,Zdo_001,ZD_001,ZdType_002,Zds_002,Zdo_002,ZD_002,ZdType_003,Zds_003,Zdo_003,ZD_003,ZdType_004,Zds_004,Zdo_004,ZD_004,ZdType_005,Zds_005,Zdo_005,ZD_005,ZdType_006,Zds_006,Zdo_006,ZD_006,ZdType_007,Zds_007,Zdo_007,ZD_007,ZdType_008,Zds_008,Zdo_008,ZD_008

'--图片列表链接
dim imhstr,imostr,NewsimageCode,Newsimage,picpath,Radiobutton,x_tp
'--图片列表链接
Dim TsString,ToString,CsString,CoString,DateType,DsString,DoString,AuthorType,AsString,AoString,AuthorStr,CopyFromType,FsString,FoString
Dim CopyFromStr,KeyType,KsString,KoString,KeyStr,NewsPaingType,NPsString,NpoString,NewsPaingStr,NewsPaingHtml
Dim ItemCollecDate,PaginationType,MaxCharPerPage,InfoGroup,Stars,InfoPoint,Hits,UpDateType,UpDateTime,IncludePicYn,DefaultPicYn,OnTop,Elite,Hot
Dim SkinID,TemplateID,Script_Iframe,Script_Object,Script_Script,Script_Div,Script_Class,Script_Span,Script_Img,Script_Font,Script_A,Script_Html,CollecListNum,CollecNewsNum,Passed,SaveFiles,CollecOrder,InputerType,Inputer,EditorType,Editor,ShowCommentLink,Script_Table,Script_Tr,Script_Td

'过滤变量
Dim Arr_Filters,FilterStr,Filteri

'采集相关的变量
Dim ContentTemp,NewsPaingNext,NewsPaingNextCode,Arr_i,NewsUrl,NewsCode,ListTypeCode,ListTypeUrlCode,TypeUrlArray,TypeNewsUrl,NewsTypeCode,PicUrls,Arr_ii,Arr_ii_2,ListTypeCode_2,ListTypeUrlCode_2,TypeUrlArray_2

'文章保存变量
Dim ArticleID,Title,Content,Author,CopyFrom,Key,IncludePic,UploadFiles,DefaultPicUrl,Coll_DefiniteUrl
'其它变量
Dim LoginData,LoginResult,OrderTemp
Dim Arr_Item,CollecNewsAll
Dim StepID

'历史记录
Dim Arr_Histrolys,His_Title,His_CollecDate,His_Result,His_Repeat,His_i 

'执行时间变量
Dim StartTime,OverTime

'图片统计
Dim Arr_Images,ImagesNum,ImagesNumAll

'列表
Dim ListUrl,ListCode,NewsArrayCode,NewsArray,ListArray,ListPaingNext
dim picpathTemp,PicUrlsTemp,DownUrlsTemp
'安装路径
Dim strInstallDir,CacheTemp,SavefilePath
Dim DiyFieldSTR_z,DiyFieldSTR_l'自定义
Dim FoundErr_1
On Error Resume Next
strInstallDir=trim(request.ServerVariables("SCRIPT_NAME"))
strInstallDir=left(strInstallDir,instrrev(lcase(strInstallDir),"/")-1)
'缓存路径
CacheTemp=Lcase(trim(request.ServerVariables("SCRIPT_NAME")))
CacheTemp=left(CacheTemp,instrrev(CacheTemp,"/"))
CacheTemp=replace(CacheTemp,"\","_")
CacheTemp=replace(CacheTemp,"/","_")
CacheTemp="ansir" & CacheTemp

'数据初始化
CollecListNum=0'列表数
CollecNewsNum=0'列表数
ArticleID=0'ID
ItemNum=Clng(Trim(Request("ItemNum")))
ListNum=Clng(Trim(Request("ListNum")))
NewsNum_i=Clng(Trim(Request("NewsNum_i")))
NewsSuccesNum=Clng(Trim(Request("NewsSuccesNum")))
NewsFalseNum=Clng(Trim(Request("NewsFalseNum")))
ImagesNumAll=Clng(Trim(Request("ImagesNumAll")))
ListPaingNext=Trim(Request("ListPaingNext"))
Itemon=Trim(Request("Itemon"))'快速采集
Itemok=Trim(Request("Itemok"))'快速采集
FoundErr=False
ItemEnd=False
ListEnd=False
ErrMsg=""

OpenConn_C

Call DelNews()'
Call CheckForm()'检察ItemID值
Dim Collecdate : Collecdate=Trim(Request("Collecdate"))
If Itemok = "yes" then 
	If Instr(Itemon,",")>0 Then
		ItemIdstr=GetItemId(Itemon,1)
		Response.write("<script>location.href='Admin_CollectionFast.asp?ItemID="&GetItemId(Itemon,0)&"&ItemNum=1&ListNum=1&NewsSuccesNum=0&NewsFalseNum=0&ImagesNumAll=0&NewsNum_i=0&Itemon="& ItemIdstr &"&Collecdate="& Collecdate &"';</script>")'到页面
	Else
		Response.write("<script>location.href='Admin_CollectionFast.asp?ItemID="&Itemon&"&ItemNum=1&ListNum=1&NewsSuccesNum=0&NewsFalseNum=0&ImagesNumAll=0&NewsNum_i=0&Collecdate="& Collecdate &"';</script>")'到页面
	End if
	Response.end	
End if

If Instr(ItemID,",")>0 Then
	ItemIdstr=GetItemId(ItemID,1)
	Response.write("<script>location.href='Admin_CollectionFast.asp?ItemID="&GetItemId(ItemID,0)&"&ItemNum=1&ListNum=1&NewsSuccesNum=0&NewsFalseNum=0&ImagesNumAll=0&NewsNum_i=0&Itemon="& ItemIdstr&"&Collecdate="& Collecdate &"';</script>")'到页面
	Response.end
End if

If FoundErr<>True Then
	Call SetCache()'项目信息写入缓存
End If
If FoundErr=True Then
	Call Cl.ShowErr(ErrMsg)
Else
	Call GetCache()
	Call Main()
	Collection_Fast
End If
'关闭数据库链接
Call CloseConn_C()
footer
%>
 
<%Sub Main
header%>
<body leftmargin="0" topmargin="0" marginwidth="0" marginheight="0">
<br>
<%End Sub

Sub CheckForm()'提取表单
	ItemID=Trim(Request("ItemID"))
	'检察表单
	If ItemID="" Then
		FoundErr=True
		ErrMsg=ErrMsg & "<br><li>请您选择项目!</li>"
	Else
		If Instr(ItemID,",")>0 Then
			ItemID=Replace(ItemID," ","")
		End If
		Response.Flush()
		set rs=Conn_C.execute("select top 1 * from Item Where ItemID in(" & ItemID &")" )
			if Cl.Execute("select count(ClassID) from Cl_Class Where ClassID=" & RS("ClassID"))(0)=0 then
		FoundErr=True
		ErrMsg=ErrMsg & "<br><li>请您设置频道栏目! </li>"
		rs.close
		set rs=nothing
		end if
	End If
End Sub

'==================================================
'过程名：SetCache1
'作  用：存取缓存
'参  数：无
'==================================================
Sub GetCache()
	Dim myCache
	Set myCache=new Cls_Cache

	'项目信息
	myCache.name=CacheTemp & "items"
	If myCache.valid then 
		Arr_Item=myCache.value
	Else
		ItemEnd=True
	End If

	'过滤信息
	myCache.name=CacheTemp & "filters"
	If myCache.valid then 
		Arr_Filters=myCache.value
	End If

	'历史记录
	myCache.name=CacheTemp & "histrolys"
	If myCache.valid then 
		Arr_Histrolys=myCache.value
	End If

	Set myCache=Nothing
End Sub

Sub SetCache()'项目信息写入缓存
	SqlItem ="select * from Item where ItemID in(" & ItemID & ")"
	Set RsItem=Server.CreateObject("adodb.recordset")
	RsItem.Open SqlItem,Conn_C,1,1
	If Not RsItem.Eof Then
		Arr_Item=RsItem.GetRows()
	End If
	RsItem.Close
	Set RsItem=Nothing

	Set myCache=new Cls_Cache
	myCache.name=CacheTemp & "items"
	Call myCache.clean()
	If IsArray(Arr_Item)=True Then
		myCache.add Arr_Item,Dateadd("n",1000,now)
	Else
		FoundErr=True
		ErrMsg=ErrMsg & "<br>发生意外错误！"
	End If

	'过滤信息
	SqlItem ="select * from Filters where Flag=True"
	Set RsItem=Server.CreateObject("adodb.recordset")
	RsItem.Open SqlItem,Conn_C,1,1
	If Not RsItem.Eof Then
		Arr_Filters=RsItem.GetRows()
	End If
	RsItem.Close
	Set Rsitem=Nothing

	myCache.name=CacheTemp & "filters"
	Call myCache.clean()
	If IsArray(Arr_Filters)=True Then
		myCache.add Arr_Filters,Dateadd("n",1000,now)
	End If

	'历史记录
	SqlItem ="select NewsUrl,Title,CollecDate,Result from Histroly"
	Set RsItem=Server.CreateObject("adodb.recordset")
	RsItem.Open SqlItem,Conn_C,1,1
	If Not RsItem.Eof Then
		Arr_Histrolys=RsItem.GetRows()
	End If
	RsItem.Close
	Set RsItem=Nothing

	myCache.name=CacheTemp & "histrolys"
	Call myCache.clean()
	If IsArray(Arr_Histrolys)=True Then
		myCache.add Arr_Histrolys,Dateadd("n",1000,now)
	End If

	set myCache=nothing
End Sub
Sub DelNews()
	Conn_C.execute("Delete From [NewsList]")
End Sub

'=============快速采集==================	
Public Sub Collection_Fast
	If ItemEnd<>True Then
		If (ItemNum-1)>Ubound(Arr_Item,2) then
			ItemEnd=True
		Else
			SetItems()
		End If
	End If
	If ItemEnd<>True Then
	If ListPaingType=0 Then
		If ListNum=1 Then
			ListUrl=ListStr
		Else
			ListEnd=True
		End If
	ElseIf ListPaingType=1 Then
		if listnum=1 and ListPaingID1<>1 and  ListPaingID2<>1 then 
			ListUrl=ListStr
		else
			If ListPaingID1>ListPaingID2 then
				If (ListPaingID1-ListNum+1)<ListPaingID2 or (ListPaingID1-ListNum+1)<0 Then
					Listend=True
				Else
					ListUrl=Replace(ListPaingStr2,"{$ID}",Cstr(ListpaingID1-ListNum+1))
				End if
			Else
				If (ListPaingID1+ListNum-1)>ListPaingID2 Then
					ListEnd=True
				Else
					ListUrl=Replace(ListPaingStr2,"{$ID}",CStr(ListPaingID1+ListNum-1))
				End If
			End If   
		end if   
	ElseIf ListPaingType=2 Then
		ListArray=Split(ListPaingStr3,"|")
		If (ListNum-1)>Ubound(ListArray) Then
			ListEnd=True
		Else
			ListUrl=ListArray(ListNum-1)
		End If
	ElseIf ListPaingType=3 Then
		If ListNum=1 Then
			ListUrl=ListStr
			ListCode=ListStr
			application.Lock()
			application("IPQ_SS")=ListUrl
			application.UnLock()
		Else
			ListUrl=application("IPQ_SS")
			ListCode=CGet.GetHttpPage(ListUrl,"GB2312")
			ListCode=CGet.GetBody(ListCode,LPsString,LPoString,False,False)
		End if
		If ListCode<>"$False$" or ListCode<>"" Then
			ListCode=Trim(CGet.FormatRemoteUrl(ListCode,ListStr))
			ListUrl=ListCode
			application.Lock()
			application("IPQ_SS")=ListUrl
			application.UnLock()
		Else
			ListEnd=True
		End if    	
	End If
	
	If ListNum>CollecListNum And CollecListNum<>0 Then
		ListEnd=True
	End if
	End If
	
	
	If ItemEnd=True Then
	ErrMsg= "<br>采集任务全部完成"
	ErrMsg=ErrMsg & "<br>成功采集： "  &  NewsSuccesNum  &  "  条,失败： "    &  NewsFalseNum  &  "  条,图片：" & ImagesNumAll & "  张"
	Call DelCache()
	ErrMsg=ErrMsg & "<meta http-equiv=""refresh"" content=""1;url="& CGet.GetItemConfig("FileName",ModuleID) &""">"
	Else
	If ListEnd=True Then
	If Itemon<>"" then  Itemok= "yes"'全选采集
		If Instr(Itemon,",")>0 or Itemon<>"" Then
			if Collecdate<>"" Then 
					Collecdate=Day(now())
					response.write("<script>location.href='Admin_Timing.asp?action=GoTiming&Collecdate="&  Day(now()) &"';</script>")'到页面
			Else
					response.write("<script>location.href='Admin_CollectionFast.asp?ItemID="& ItemID &"&ItemNum=" & ItemNum & "&ListNum=0&NewsSuccesNum=" & NewsSuccesNum & "&NewsFalseNum=" & NewsFalseNum & "&ImagesNumAll=" & ImagesNumAll & "&ListPaingNext=" & ListPaingNext &"&NewsNum_i="& 0 &"&Itemok="& Itemok &"&Itemon="& Itemon &"&Collecdate="& Collecdate &"';</script>")'完成
					Response.end
			End if	
		End if
		ItemNum=ItemNum+1
		ListNum=1
		ErrMsg="<br>" & ItemName & "  项目所有列表采集完成，正在整理数据请稍后..."
		ErrMsg=ErrMsg & "<meta http-equiv=""refresh"" content=""1;url="& CGet.GetItemConfig("FileName",ModuleID) &""">"
	End If
	End If
	
	TopItem()'Top顶部
	If ItemEnd=True Or ListEnd=True Then
		If ItemEnd<>True Then
		SetCache_His()
		End If
		Call Cl.ShowSuc(ErrMsg)
	Else
	FoundErr=False
	ErrMsg=""
	Call StartCollection()'开始采集
	FootItem2()
	End  If	
End Sub

Sub StartCollection'开始采集
IF ModuleID <> 0 then 
	Set Rs = Conn_C.execute("Select top 1 Dir,MaxFileSize,FileExtName,Timeout from ModuleInfo where ID="& ModuleID )
Else
	Set Rs = Conn_C.execute("Select top 1 Dir,MaxFileSize,FileExtName,Timeout from ModuleInfo where ID=1" )
End if
CGet.CjTimeout=Rs("Timeout") 
CGet.DownExtName=Rs("FileExtName")
CGet.MaxSize=Rs("MaxFileSize")
Rs.close : Set Rs=Nothing
Cl.Get_ChannelSetting(ChannelID)
If NewsSuccesNum >= CollecNewsNum And CollecNewsNum<>0 then 
	If Itemon="" then
		if Collecdate<>"" then
			response.write("<script>location.href='Admin_Timing.asp?action=GoTiming&Collecdate="&  Day(now()) &"';</script>")
		Else
			Response.Write "<br> &nbsp;&nbsp;&nbsp;&nbsp;采集完成，正在整理数据请稍后..." 
			Response.Write  "<meta http-equiv=""refresh"" content=""1;url="& CGet.GetItemConfig("FileName",ModuleID) &""">"
		End if
	Else
		response.write  "<script>location.href='Admin_CollectionFast.asp?ItemID="& ItemID &"&ItemNum=1&ListNum=1&NewsSuccesNum=0&NewsFalseNum=0&ImagesNumAll=0&NewsNum_i=0&Itemon="& Itemon &"&Itemok=yes&Collecdate="& Collecdate &"';</script>"
	End if
	Response.end
End if
'第一次采集时登录
If LoginType=1 And ListNum=1 then
	LoginData=CGet.UrlEncoding(LoginUser & "&" & LoginPass)
	LoginResult=CGet.PostHttpPage(LoginUrl,LoginPostUrl,LoginData,Encoding)
	If Instr(LoginResult,LoginFalse)>0 Then
		FoundErr=True
		ErrMsg=ErrMsg & "<br><li>在登录网站时发生错误，请确保登录信息的正确性！</li>"
	End If
End If
If FoundErr<>True then
   ListCode=CGet.ReplaceTrim(CGet.GetHttpPage(ListUrl,Encoding))
   GetListPaing()
   If ListCode="$False$" Then
	  FoundErr=True