article_paste.asp

SK信息采集2.0功能介绍: 1.可针对任何静态网页,动态网页进行采集。包括htm,html,shtml,ASP,ASPX,JSP,PHP等。 2.增加自定文件采集.用户可采集网页中的所有文件.

			   IRS("ArticleTemplateID") = RS("ArticleTemplateID")
			   IRS("ArticleFnameType") = RS("ArticleFnameType")
			   IRS("ArticleFsoType") = RS("ArticleFsoType")
			   IRS("FolderDomain") = RS("FolderDomain")
			   IRS("FolderOrder") = RS("FolderOrder")
			   IRS("ChannelID") = RS("ChannelID")
			   IRS("DelTF") = RS("DelTF")
			   IRS("OrderID") = RS("OrderID")
			   IRS("ClassPurview")=RS("ClassPurview")
			   IRS("CommentTF")=RS("CommentTF")
			   IRS("DefaultReadPoint")=RS("DefaultReadPoint")
			   IRS("DefaultChargeType")=RS("DefaultChargeType")
			   IRS("DefaultPitchTime")=RS("DefaultPitchTime")
			   IRS("DefaultReadTimes")=RS("DefaultReadTimes")
			   IRS("DefaultDividePercent")=RS("DefaultDividePercent")
			  IRS.Update
			  AddCopyFolder = IRS("TS") & "|||" & IRS("Folder")
			  IRS.Close
			  Set IRS = Nothing
		End Function
		'添加复制的文章
		'参数NewID--当前文章的ID，取0代表复制目录下的所有文章 ，Flag true--取"复制(n)"样式,OriFolderID--原文章所在目录的ID,NewClassID--文章的新目录
		Function AddCopyArticle(NewID, Flag, OriFolderID, NewClassID)
		  Dim RS, IRS, NewsID, OriTitle, SqlStr
		  Set RS = Server.CreateObject("Adodb.RecordSet")
		  If NewID = 0 Then
			SqlStr = "Select * From KS_Article Where Tid='" & OriFolderID & "' And DelTF=0"
		  Else
			SqlStr = "Select * From KS_Article Where Newsid='" & NewID & "' And DelTF=0"
		  End If
		  RS.Open SqlStr, conn, 1, 1
		  If Not RS.EOF Then
			 Set IRS = Server.CreateObject("Adodb.RecordSet")
			 Do While Not RS.EOF
				If Flag = True Then
				   OriTitle = GetNewTitle(NewClassID, RS("Title"))
				Else
				   OriTitle = RS("Title")
				End If
			   IRS.Open "Select * From KS_Article Where NewsID=Null", conn, 1, 3
				IRS.AddNew
				'文章ID
				NewsID = KSCMS.GetInfoID(1)   '取文章的唯一ID
				IRS("NewsId") = NewsID
				IRS("TitleType") = RS("TitleType")
				IRS("Title") = OriTitle
				IRS("TitleFontColor") = RS("TitleFontColor")
				IRS("TitleFontType") = RS("TitleFontType")
				IRS("SubTitle") = RS("Subtitle")
				IRS("ArticleContent") = RS("ArticleContent")
				IRS("Changes") = RS("Changes")
				IRS("PicNews") = RS("PicNews")
				IRS("PicUrl") = RS("PicUrl")
				IRS("Recommend") = RS("Recommend")
				IRS("Rolls") = RS("Rolls")
				IRS("Strip") = RS("Strip")
				IRS("Popular") = RS("Popular")
				IRS("Verific") = RS("Verific")
				IRS("Tid") = NewClassID
				IRS("SpecialID") = RS("SpecialID")
				IRS("KeyWords") = RS("KeyWords")
				IRS("Author") = RS("Author")
				IRS("Origin") = RS("Origin")
				IRS("Editor") = RS("Editor")
				IRS("AddDate") = RS("AddDate")
				IRS("Rank") = RS("Rank")
				IRS("Slide") = RS("Slide")
				IRS("Comment") = RS("Comment")
				IRS("BeyondSavePic") = RS("BeyondSavePic")
				IRS("TemplateID") = RS("TemplateID")
				IRS("Hits") = RS("Hits")
				IRS("ArticleFsoType") = RS("ArticleFsoType")
				IRS("Fname") = KSCMS.MakeRandom(15) & Mid(Trim(RS("Fname")), InStrRev(Trim(RS("Fname")), "."))
				IRS("ArticleInput") = RS("ArticleInput")
				IRS("RefreshTF") = RS("RefreshTF")
				IRS("DelTF") = 0
				IRS("OrderID") = 1
				IRS("InfoPurview")=RS("InfoPurview")
		        IRS("ArrGroupID")=RS("ArrGroupID")
		        IRS("ReadPoint")=RS("ReadPoint")
		        IRS("ChargeType")=RS("ChargeType")
		        IRS("PitchTime")=RS("PitchTime")
		        IRS("ReadTimes")=RS("ReadTimes")
		        IRS("DividePercent")=RS("DividePercent")

				IRS.Update
				RS.MoveNext
				IRS.Close
			 Loop
		  Else
			RS.Close
			Set RS = Nothing
			Exit Function
		  End If
		  RS.Close
		  Set RS = Nothing
		  Set IRS = Nothing
		End Function
		Function GetNewTitle(NewClassID, OriTitle)
			Dim RSC, CheckRS
			On Error Resume Next
			Set RSC = Server.CreateObject("Adodb.RecordSet")
			Set CheckRS = Server.CreateObject("Adodb.RecordSet")
			  CheckRS.Open "Select * From KS_Article Where TID='" & NewClassID & "' And Title='" & OriTitle & "' And DelTF=0", conn, 1, 1
			  If Not CheckRS.EOF Then
				 RSC.Open "Select * From KS_Article Where TID='" & NewClassID & "' And Title Like '复制%" & OriTitle & "' And DelTF=0 Order By ID Desc", conn, 1, 1
				 If Not RSC.EOF Then
					RSC.MoveFirst
					If RSC.RecordCount = 1 Then
					   RSC.Close
					   Set RSC = Nothing
					  CheckRS.Close
					  Set CheckRS = Nothing
					  GetNewTitle = "复制(1) " & OriTitle
					  Exit Function
					Else
					  GetNewTitle = "复制(" & CInt(Left(Split(RSC("Title"), "(")(1), 1)) + 1 & ") " & OriTitle
					End If
					 CheckRS.Close
					 RSC.Close
					 Set RSC = Nothing
					 Set CheckRS = Nothing
				 Else
				  RSC.Close
				  Set RSC = Nothing
				  CheckRS.Close
				  Set CheckRS = Nothing
				  GetNewTitle = "复制 " & OriTitle
				  Exit Function
				 End If
				 RSC.Close
				 Set RSC = Nothing
			  Else
				CheckRS.Close
				Set CheckRS = Nothing
				GetNewTitle = OriTitle
				Exit Function
			  End If
		End Function
		'复制子目录
		Sub CopySubFolder(ParentID, SubDestFolder, SubDestTS, DestFolder)
			Dim RSTS, OriSubClassID, ClassID, Curr, Folder
			Set RSTS = Server.CreateObject("Adodb.RecordSet")
			RSTS.Open "Select * From KS_Class Where TN='" & ParentID & "' And DelTF=0 Order BY TJ Asc", conn, 1, 1
			If Not RSTS.EOF Then
			  Do While Not RSTS.EOF
				 OriSubClassID = RSTS("ID")
				 Folder = RSTS("Folder")
				 Folder = DestFolder & Split(Left(Folder, Len(Folder) - 1), "/")(UBound(Split(Left(Folder, Len(Folder) - 1), "/"))) & "/"
				 ClassID = KSCMS.GetClassID()
				 Curr = AddCopyFolder(ClassID, RSTS("FolderName"), Folder, SubDestTS, UBound(Split(RSTS("TS"), ",")) - 1, SubDestFolder, RSTS)
				 '复制子目录下的文章到新子目录
				  Call AddCopyArticle(0, False, OriSubClassID, ClassID)
				  Call CopySubFolder(OriSubClassID, ClassID, Split(Curr, "|||")(0), Split(Curr, "|||")(1))
				RSTS.MoveNext
			  Loop
			End If
			RSTS.Close
			Set RSTS = Nothing
		End Sub
		
		'检查是否允许操作
		Function CheckOp(DestFolderID, DFolderID, OpStr, SFlag)
		   Dim RS, ObjRS, I
		   Set RS = Server.CreateObject("Adodb.RecordSet")
		   Set ObjRS = Server.CreateObject("Adodb.RecordSet")
		   For I = LBound(DFolderID) To UBound(DFolderID)
			 RS.Open "Select TN,ID,TJ,TS,FolderName From KS_Class Where ID ='" & DFolderID(I) & "'", conn, 1, 1
			 If Not RS.EOF Then
				ObjRS.Open "Select TS,ID,TJ,TN From KS_Class Where ID='" & DestFolderID & "'", conn, 1, 1
				If Not ObjRS.EOF Then
					 If InStr(ObjRS("TS"), Trim(RS("TS"))) <> 0 Then   '判断目标目录是否是该目录的子目录
						  If ObjRS("TJ") = RS("TJ") Then
							RS.Close
							ObjRS.Close
							Set ObjRS = Nothing
							Set RS = Nothing
							CheckOp = False
							Call KSCMS.AlertHistory("无法" & OpStr & ":目标目录和源目录相同!", 1)
							Set KSCMS = Nothing
							Exit Function
						  ElseIf ObjRS("TJ") > RS("TJ") Then
							RS.Close
							ObjRS.Close
							Set ObjRS = Nothing
							Set RS = Nothing
							CheckOp = False
							Call KSCMS.AlertHistory("无法" & OpStr & ":目标目录是源目录的子目录!", 1)
							Set KSCMS = Nothing
							Exit Function
						  End If
					End If
					ObjRS.Close
					If Not SFlag Then
					   ObjRS.Open "Select FolderName From KS_Class Where FolderName='" & RS("FolderName") & "' And TN='" & DestFolderID & "'", conn, 1, 1
					   If Not ObjRS.EOF Then
							RS.Close
							ObjRS.Close
							Set ObjRS = Nothing
							Set RS = Nothing
							CheckOp = False
							Call KSCMS.AlertHistory("操作失败,存在相同目录名称!", 1)
							Set KSCMS = Nothing
							Exit Function
					   End If
					  ObjRS.Close
					End If
					RS.Close
				Else
				  RS.Close
				  Set RS = Nothing
				  CheckOp = False
				  Call KSCMS.AlertHistory("参数传递出错!", 1)
				  Set KSCMS = Nothing
				  Exit Function
				End If
			 Else
			   RS.Close
			   Set RS = Nothing
			   CheckOp = False
			   Call KSCMS.AlertHistory("参数传递出错!", 1)
			   Set KSCMS = Nothing
			   Exit Function
			 End If
		   Next
		   CheckOp = True
		End Function
End Class
%>