admin_special.asp

个人网站比较简短

    Do While Not rsOrder.EOF
        tOrderID = rsOrder("OrderID")     '得到要提升位置的OrderID，包括子专题
        Conn.Execute ("update PE_Special set OrderID=OrderID-1 where OrderID=" & tOrderID)
        i = i + 1
        If i > MoveNum Then
            Exit Do
        End If
        rsOrder.MoveNext
    Loop
    rsOrder.Close
    Set rsOrder = Nothing
    
    '然后再将当前专题从最后移到相应位置，包括子专题
    Conn.Execute ("update PE_Special set OrderID=" & tOrderID & " where SpecialID=" & SpecialID)
    Call CreateJS_Special
    Call CloseConn
    Response.Redirect "Admin_Special.asp?Action=Order&ChannelID=" & ChannelID
End Sub

Sub UniteSpecial()
    Dim SpecialID, TargetSpecialID, SuccessMsg
    SpecialID = Trim(Request("SpecialID"))
    TargetSpecialID = Trim(Request("TargetSpecialID"))
    If SpecialID = "" Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>请指定要合并的专题！</li>"
    Else
        SpecialID = PE_CLng(SpecialID)
    End If
    If TargetSpecialID = "" Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>请指定目标专题！</li>"
    Else
        TargetSpecialID = PE_CLng(TargetSpecialID)
    End If
    If SpecialID = TargetSpecialID Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>请不要在相同专题内进行操作</li>"
    End If
    If FoundErr = True Then
        Exit Sub
    End If
    If FoundErr = True Then
        Exit Sub
    End If

    Dim rsInfo
    Set rsInfo = Conn.Execute("select * from PE_InfoS where SpecialID=" & SpecialID & " order by InfoID desc")
    Do While Not rsInfo.EOF
        If PE_CLng(Conn.Execute("select count(InfoID) from PE_InfoS where ModuleType=" & rsInfo("ModuleType") & " and SpecialID=" & TargetSpecialID & " and ItemID=" & rsInfo("ItemID") & "")(0)) > 0 Then
            Conn.Execute ("delete from PE_InfoS where InfoID=" & rsInfo("InfoID") & "")
        Else
            Conn.Execute ("update PE_InfoS set SpecialID=" & TargetSpecialID & " where InfoID=" & rsInfo("InfoID") & "")
        End If
        rsInfo.MoveNext
    Loop
    rsInfo.Close
    Set rsInfo = Nothing
    

    '删除被合并专题
    Conn.Execute ("delete from PE_Special where SpecialID=" & SpecialID)
    Conn.Execute ("update PE_Channel set SpecialCount=SpecialCount-1 where ChannelID=" & ChannelID & "")
    SuccessMsg = "专题合并成功！已经将被合并专题的所有数据转入目标专题中。"
    Call CreateJS_Special
    Call WriteSuccessMsg(SuccessMsg, ComeUrl)
End Sub

Sub CreateAllSpecialDir()
    'On Error Resume Next
    If Not fso.FolderExists(Server.MapPath(HtmlDir & "/Special")) Then
        fso.CreateFolder Server.MapPath(HtmlDir & "/Special")
    End If

    Dim sqlSpecial, rsSpecial, i, iDepth
    sqlSpecial = "select * from PE_Special where ChannelID=" & ChannelID & " order by OrderID"
    Set rsSpecial = Conn.Execute(sqlSpecial)
    Do While Not rsSpecial.EOF
        If Not fso.FolderExists(Server.MapPath(HtmlDir & "/Special/" & rsSpecial("SpecialDir"))) Then
            fso.CreateFolder Server.MapPath(HtmlDir & "/Special/" & rsSpecial("SpecialDir"))
        End If
        rsSpecial.MoveNext
    Loop
    rsSpecial.Close
    Set rsSpecial = Nothing
    Call WriteSuccessMsg("生成所有专题的目录成功！", ComeUrl)
End Sub

Sub DelAllSpecialDir()
    On Error Resume Next
    Dim theFolder, theSubFolder, strFolderName
    Set theFolder = fso.GetFolder(Server.MapPath(HtmlDir & "/Special"))
    For Each theSubFolder In theFolder.SubFolders
        strFolderName = theSubFolder.name
        theSubFolder.Delete
        If Err Then
            Err.Clear
            FoundErr = True
            ErrMsg = ErrMsg & "<li>删除目录：" & strFolderName & "失败！可能当前目录正在使用中。请稍后再试！</li>"
        End If
    Next
    If FoundErr <> True Then
        Call WriteSuccessMsg("删除所有栏目的目录成功！", ComeUrl)
    End If
End Sub

Sub CreateJS_Special()

    If ObjInstalled_FSO = False Then
        Exit Sub
    End If

    Dim hf, strSpecial, SpecialPath
    '全站专题
    If ChannelID = 0 Then
        SpecialPath = InstallDir & "js"
        JS_SpecialNum = 10
    Else
        SpecialPath = InstallDir & ChannelDir & "/js"
    End If

    If Not fso.FolderExists(Server.MapPath(SpecialPath)) Then
        fso.CreateFolder (Server.MapPath(SpecialPath))
    End If
    
    strSpecial = GetSpecialList(JS_SpecialNum)
    Call WriteToFile(SpecialPath & "/ShowSpecialList.js", "document.write(""" & strSpecial & """);")
End Sub

Sub DoBatch()
    Dim SpecialID
    Dim sql, rsSpecial, i, trs
    SpecialID = Trim(Request("SpecialID"))
	If IsValidID(SpecialID) = False Then
		SpecialID = ""
	End If

    If SpecialID = "" Then
        FoundErr = True
        ErrMsg = ErrMsg & "<li>请先选定要批量修改设置的专题！</li>"
    End If


    If FoundErr = True Then
        Exit Sub
    End If
    
    If InStr(SpecialID, ",") > 0 Then
        SpecialID = ReBuild(SpecialID)
        sql = "select * from PE_Special where SpecialID in (" & SpecialID & ")"
    Else
        sql = "select * from PE_Special where SpecialID=" & SpecialID
    End If
    Set rsSpecial = Server.CreateObject("Adodb.recordset")
    rsSpecial.Open sql, Conn, 1, 3
    Do While Not rsSpecial.EOF
        If Trim(Request("ModifyIsElite")) = "Yes" Then rsSpecial("IsElite") = PE_CBool(Trim(Request("IsElite")))
        If Trim(Request("ModifyOpenType")) = "Yes" Then rsSpecial("OpenType") = PE_CLng(Trim(Request("OpenType")))
        If Trim(Request("ModifyMaxPerPage")) = "Yes" Then rsSpecial("MaxPerPage") = PE_CLng(Trim(Request("MaxPerPage")))
        If Trim(Request("ModifySkinID")) = "Yes" Then rsSpecial("SkinID") = PE_CLng(Trim(Request("SkinID")))
        If Trim(Request("ModifyTemplateID")) = "Yes" Then rsSpecial("TemplateID") = PE_CLng(Trim(Request("TemplateID")))
        rsSpecial.Update
        rsSpecial.MoveNext
        Set trs = Nothing
    Loop
    rsSpecial.Close
    Set rsSpecial = Nothing
    Call ClearSiteCache(ChannelID)
    Call CreateJS_Special
    Call WriteSuccessMsg("批量设置专题属性成功！", ComeUrl)
End Sub

Function ReBuild(ByVal iSpecialID)
    Dim arrSpecialID, SpecialArr, i
    arrSpecialID = Split(iSpecialID, ",")
    SpecialArr = ""
    For i = 0 To UBound(arrSpecialID)
        If Trim(arrSpecialID(i)) <> "" And Trim(arrSpecialID(i)) <> "0" Then
            If SpecialArr = "" Then
                SpecialArr = arrSpecialID(i)
            Else
                SpecialArr = SpecialArr & "," & arrSpecialID(i)
            End If
        End If
    Next
    ReBuild = SpecialArr
End Function



'=================================================
'函数名：GetSpecialList
'作  用：以竖向列表方式显示专题名称
'参  数：SpecialNum  ------最多显示多少个专题名称
'=================================================
Function GetSpecialList(SpecialNum)
    Dim sqlSpecial, rsSpecial, strSpecial, i
    If SpecialNum <= 0 Or SpecialNum > 100 Then
        SpecialNum = 10
    End If
    sqlSpecial = "select SpecialID,SpecialName,SpecialDir,Tips from PE_Special where ChannelID=" & ChannelID & " and IsElite=" & PE_True & " order by OrderID"
    Set rsSpecial = Conn.Execute(sqlSpecial)
    If rsSpecial.BOF And rsSpecial.EOF Then
        strSpecial = "&nbsp;没有任何专题栏目"
    Else

        i = 0
        Do While Not rsSpecial.EOF
            If ChannelID = 0 Then
                If FileExt_SiteSpecial <> ".asp" Then
                    strSpecial = strSpecial & "<li><a href='" & InstallDir & "Special/" & rsSpecial(2) & "/Index" & FileExt_SiteSpecial & "' title='" & rsSpecial(3) & "'>" & rsSpecial(1) & "</a></li>"
                Else
                    strSpecial = strSpecial & "<li><a href='" & InstallDir & "ShowSpecial.asp?SpecialID=" & rsSpecial(0) & "' title='" & Trim(nohtml(rsSpecial(3))) & "'>" & rsSpecial(1) & "</a></li>"
                End If
            Else
                If UseCreateHTML = 1 Or UseCreateHTML = 3 Then
                    strSpecial = strSpecial & "<li><a href='" & ChannelUrl & "/Special/" & rsSpecial(2) & "/Index" & FileExt_List & "' title='" & rsSpecial(3) & "'>" & rsSpecial(1) & "</a></li>"
                Else
                    strSpecial = strSpecial & "<li><a href='" & ChannelUrl & "/ShowSpecial.asp?SpecialID=" & rsSpecial(0) & "' title='" & Trim(nohtml(rsSpecial(3))) & "'>" & rsSpecial(1) & "</a></li>"
                End If
            End If

            rsSpecial.MoveNext
            i = i + 1
            If i >= SpecialNum Then Exit Do
        Loop
    End If
    If Not rsSpecial.EOF Then
        strSpecial = strSpecial & "<p align='right'><a href='" & ChannelUrl & "/SpecialList.asp'>更多专题</a></p>"
    End If
    rsSpecial.Close
    Set rsSpecial = Nothing
    GetSpecialList = strSpecial
End Function
%>