picture_paste.asp

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

       IRS("TopFlag") = RS("TopFlag")
       IRS("FolderFsoIndex") = RS("FolderFsoIndex")
       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, PicID, OriTitle, SqlStr
  Set RS = Server.CreateObject("Adodb.RecordSet")
  If NewID = 0 Then
    SqlStr = "Select * From KS_Photo Where Tid='" & OriFolderID & "' And DelTF=0"
  Else
    SqlStr = "Select * From KS_Photo Where PicID='" & 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_Photo Where PicID is Null", conn, 1, 3
        IRS.AddNew
        '图片ID
        PicID = KSCMS.GetInfoID(2)   '取唯一ID
        IRS("PicID") = PicID
        IRS("Title") = OriTitle
        IRS("PhotoUrl") = RS("PhotoUrl")
        IRS("PicUrls") = RS("PicUrls")
        IRS("PictureContent") = RS("PictureContent")
        IRS("Recommend") = RS("Recommend")
        IRS("Rolls") = RS("Rolls")
        IRS("Strip") = RS("Strip")
        IRS("Popular") = RS("Popular")
        IRS("Verific") = RS("Verific")
        IRS("Tid") = NewClassID
        IRS("KeyWords") = RS("KeyWords")
        IRS("Author") = RS("Author")
        IRS("Origin") = RS("Origin")
        IRS("AddDate") = RS("AddDate")
        IRS("Rank") = RS("Rank")
        IRS("Slide") = RS("Slide")
        IRS("BeyondSavePic") = RS("BeyondSavePic")
        IRS("TemplateID") = RS("TemplateID")
        IRS("Hits") = RS("Hits")
        IRS("HitsByDay") = RS("HitsByDay")
        IRS("HitsByWeek") = RS("HitsByWeek")
        IRS("HitsByMonth") = RS("HitsByMonth")
        IRS("PictureFsoType") = RS("PictureFsoType")
        IRS("Fname") = KSCMS.MakeRandom(15) & Mid(Trim(RS("Fname")), InStrRev(Trim(RS("Fname")), "."))
        IRS("PictureInput") = RS("PictureInput")
        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_Photo Where TID='" & NewClassID & "' And Title='" & OriTitle & "' And DelTF=0", conn, 1, 1
      If Not CheckRS.EOF Then
         RSC.Open "Select * From KS_Photo 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
%>