<%
Dim uid, rsRole, isAdmin
uid = trim(request("uid"))
if trim(Lcase(AdminName)) = "admin" then
isAdmin = true
else
isAdmin = false
end if
ParentID = trim(request("ParentID"))
if ParentID = "" then
ParentID = 0
else
ParentID = CLng(ParentID)
end if
%>
<%=systemPageTitle%>
数据载入中……
<%
Dim arrInvalidDir
Dim pNum, pNum2, OpenTyClass, iOrderID, StructureType, HtmlDir
Dim ClassLink
arrInvalidDir = "HTML,JS,Special,List,Images,UploadFiles,UploadSoft,UploadSoftPic,UploadThumbs,UploadPhotos,UploadFlash,UploadVideo,UploadMusic"
%>
<%
Select Case Action
Case "Add"
Call AddClass
Case "SaveAdd"
Call SaveAdd
Case "Modify"
Call Modify
Case "SaveModify"
Call SaveModify
Case "Move"
Call MoveClass
Case "SaveMove"
Call SaveMove
Case "Del"
Call DeleteClass
Case "Clear"
Call ClearClass
Case "UpOrder"
Call UpOrder
Case "DownOrder"
Call DownOrder
Case "Order"
Call order
Case "UpOrderN"
Call UpOrderN
Case "DownOrderN"
Call DownOrderN
Case "OrderN"
Call OrderN
Case "Reset"
Call Reset
Case "SaveReset"
Call SaveReset
Case "Unite"
Call Unite
Case "SaveUnite"
Call SaveUnite
Case "Batch"
Call ShowBatch
Case "DoBatch"
Call DoBatch
Case "Patch"
Call Patch
Case "DoPatch"
Call DoPatch
Case "ResetChildClass"
Call ResetChildClass
Case "CreateJS"
Call WriteSuccessMsg("已经成功生成菜单JS文件。", ComeUrl)
Case Else
Call main
End Select
If FoundErr = True Then
Call WriteErrMsg(ErrMsg, ComeUrl)
End If
Sub main()
Dim arrShowLine(20), i
For i = 0 To UBound(arrShowLine)
arrShowLine(i) = False
Next
Dim sqlClass, rsClass, iDepth, ClassDir, ClassItemDir
sqlClass = "select * from t_area where ChannelID=" & ChannelID & " order by RootID,OrderID"
Set rsClass = Conn.Execute(sqlClass)
%>
ID
菜单名称及目录
操作选项
<%
If rsClass.BOF And rsClass.EOF Then
Response.Write "
没有任何菜单
"
Else
Do While Not rsClass.EOF
%>
<%=rsClass("t_classid")%>
<%
iDepth = rsClass("Depth")
If rsClass("NextID") > 0 Then
arrShowLine(iDepth) = True
Else
arrShowLine(iDepth) = False
End If
If iDepth > 0 Then
For i = 1 To iDepth
If i = iDepth Then
If rsClass("NextID") > 0 Then
Response.Write ""
Else
Response.Write ""
End If
Else
If arrShowLine(i) = True Then
Response.Write ""
Else
Response.Write ""
End If
End If
Next
End If
If rsClass("Child") > 0 Then
Response.Write ""
Else
Response.Write ""
End If
If rsClass("Depth") = 0 Then
Response.Write ""
End If
Response.Write "" & rsClass("ClassName") & ""
If rsClass("Child") > 0 Then
Response.Write "（" & rsClass("Child") & "）"
End If
'Response.Write " " & rsClass("t_classid") & "," & rsClass("PrevID") & "," & rsClass("NextID") & "," & rsClass("ParentID") & "," & rsClass("RootID")
%>
<%
If rsClass("ClassType") = 1 Then
Response.Write "添加子菜单 | "
Else
Response.Write " | "
End If
%>
修改设置 | 移动菜单 |
删除
<%
rsClass.MoveNext
Loop
End If
rsClass.Close
Set rsClass = Nothing
%>
<%
Call WriteJS
End Sub
Sub WriteJS()
%>
<%
End Sub
Sub Modify()
Dim t_classid, sql, rsClass, i
ClassID = Trim(Request("ClassID"))
If ClassID = "" Then
FoundErr = True
ErrMsg = ErrMsg & "
参数不足！
"
Exit Sub
Else
ClassID = CLng(classid)
End If
sql = "select * from t_area where t_classid=" & ClassID
Set rsClass = Server.CreateObject("Adodb.recordset")
rsClass.Open sql, Conn, 1, 1
If rsClass.BOF And rsClass.EOF Then
FoundErr = True
ErrMsg = ErrMsg & "
找不到指定的菜单！
"
rsClass.Close
Set rsClass = Nothing
Exit Sub
End If
%>
<%
Call WriteJS
rsClass.Close
Set rsClass = Nothing
End Sub
Sub MoveClass()
Dim tChannelID
Dim ClassID, sql, rsClass, i
tChannelID = Trim(Request("tChannelID"))
ClassID = Trim(Request("ClassID"))
If tChannelID = "" Then
tChannelID = ChannelID
Else
tChannelID = CLng(tChannelID)
End If
If ClassID = "" Then
FoundErr = True
ErrMsg = ErrMsg & "
参数不足！
"
Exit Sub
Else
ClassID = CLng(ClassID)
End If
sql = "select * from t_area where t_classid=" & ClassID
Set rsClass = Server.CreateObject("Adodb.recordset")
rsClass.Open sql, Conn, 1, 3
If rsClass.BOF And rsClass.EOF Then
FoundErr = True
ErrMsg = ErrMsg & "
找不到指定的菜单！
"
Else
%>
<%
End If
rsClass.Close
Set rsClass = Nothing
End Sub
Sub order()
Dim sqlClass, rsClass, i, iCount, j
sqlClass = "select * from t_area where ChannelID=" & ChannelID & " and ParentID=0 order by RootID"
Set rsClass = Server.CreateObject("adodb.recordset")
rsClass.Open sqlClass, Conn, 1, 1
iCount = rsClass.RecordCount
%>
一 级 栏 目 排 序
<%
j = 1
Do While Not rsClass.EOF
%>
<%=rsClass("ClassName")%>
<%If j > 1 Then%>
<%Else%>
<%
End If
If iCount > j Then
%>
<%Else%>
<%End If%>
<%
j = j + 1
rsClass.MoveNext
Loop
%>
<%
rsClass.Close
Set rsClass = Nothing
End Sub
Sub OrderN()
Dim sqlClass, rsClass, i, iCount, trs, UpMoveNum, DownMoveNum
sqlClass = "select * from t_area where ChannelID=" & ChannelID & " order by RootID,OrderID"
Set rsClass = Server.CreateObject("adodb.recordset")
rsClass.Open sqlClass, Conn, 1, 1
Response.Write " "
Response.Write "
"
Response.Write "
"
Response.Write "
N 级 栏 目 排 序
"
Response.Write "
"
Do While Not rsClass.EOF
Response.Write "
"
Response.Write "
"
For i = 1 To rsClass("Depth")
Response.Write " "
Next
If rsClass("Child") > 0 Then
Response.Write ""
Else
Response.Write ""
End If
If rsClass("ParentID") = 0 Then
Response.Write ""
End If
Response.Write rsClass("ClassName")
If rsClass("Child") > 0 Then
Response.Write "(" & rsClass("Child") & ")"
End If
Response.Write "
"
If rsClass("ParentID") > 0 Then '如果不是一级菜单，则算出相同深度的菜单数目，得到该菜单在相同深度的菜单中所处位置（之上或者之下的菜单数）
'所能提升最大幅度应为For i=1 to 该版之上的版面数
Set trs = Conn.Execute("select count(t_classid) from t_area where ParentID=" & rsClass("ParentID") & " and OrderID<" & rsClass("OrderID") & "")
UpMoveNum = trs(0)
If IsNull(UpMoveNum) Then UpMoveNum = 0
UpMoveNum = CLng(UpMoveNum)
If UpMoveNum > 0 Then
Response.Write ""
Else
Response.Write "
"
End If
trs.Close
'所能降低最大幅度应为For i=1 to 该版之下的版面数
Set trs = Conn.Execute("select count(t_classid) from t_area where ParentID=" & rsClass("ParentID") & " and orderID>" & rsClass("orderID") & "")
DownMoveNum = trs(0)
If IsNull(DownMoveNum) Then DownMoveNum = 0
DownMoveNum = CLng(DownMoveNum)
If DownMoveNum > 0 Then
Response.Write ""
Else
Response.Write "
<%
End Sub
Sub ShowBatch()
%>
<%
Call WriteJS
End Sub
Sub Patch()
%>
修复菜单结构
<%
End Sub
Sub DoPatch()
Dim rsClass, sql, PrevID, trs
Set rsClass = Server.CreateObject("ADODB.Recordset")
sql = "Select t_classid,RootID,OrderID,Depth,ParentID,ParentPath,Child,arrChildID,PrevID,NextID,ClassType,ParentDir,ClassDir,ClassPurview,ItemCount from t_area where ChannelID=" & ChannelID & " and ParentID=0 order by RootID"
rsClass.Open sql, Conn, 1, 3
If rsClass.BOF And rsClass.EOF Then
rsClass.Close
Set rsClass = Nothing
Exit Sub
End If
PrevID = 0
Do While Not rsClass.EOF
rsClass("OrderID") = 0
rsClass("Depth") = 0
rsClass("ParentPath") = "0"
rsClass("PrevID") = PrevID
rsClass("NextID") = 0
rsClass("arrChildID") = CStr(rsClass("t_classid"))
If rsClass("ClassType") = 1 Then
rsClass("ParentDir") = "/"
End If
If PrevID <> rsClass("t_classid") And PrevID > 0 Then
Conn.Execute ("update t_area set NextID=" & rsClass("t_classid") & " where t_classid=" & PrevID & "")
End If
PrevID = rsClass("t_classid")
rsClass.Update
iOrderID = 1
Call UpdateClass(rsClass("t_classid"), 1, "0", "/" & rsClass("ClassDir") & "/", rsClass("ClassPurview"))
rsClass.MoveNext
Loop
rsClass.Close
Set rsClass = Nothing
Call WriteSuccessMsg("修复菜单结构成功！", ComeUrl)
End Sub
Sub UpdateClass(iParentID, iDepth, sParentPath, sParentDir, ClassPurview)
Dim rsClass, sql, PrevID, ParentPath, trs, rsChild
ParentPath = sParentPath & "," & iParentID
sql = "Select t_classid,RootID,OrderID,Depth,ParentID,ParentPath,Child,arrChildID,PrevID,NextID,ClassType,ParentDir,ClassDir,ClassPurview,ItemCount from t_area where ChannelID=" & ChannelID & " and ParentID=" & iParentID & " order by OrderID"
Set rsClass = Server.CreateObject("ADODB.Recordset")
rsClass.Open sql, Conn, 1, 3
If rsClass.BOF And rsClass.EOF Then
Conn.Execute ("update t_area set Child=0 where t_classid=" & iParentID & "")
Else
Conn.Execute ("update t_area set Child=" & rsClass.RecordCount & " where t_classid=" & iParentID & "")
PrevID = 0
Do While Not rsClass.EOF
Set rsChild = Server.CreateObject("adodb.recordset")
rsChild.Open "select arrChildID from t_area where t_classid in (" & ParentPath & ")", Conn, 1, 3
Do While Not rsChild.EOF
rsChild(0) = rsChild(0) & "," & rsClass("t_classid")
rsChild.Update
rsChild.MoveNext
Loop
rsChild.Close
Set rsChild = Nothing
rsClass("OrderID") = iOrderID
rsClass("Depth") = iDepth
rsClass("ParentPath") = ParentPath
rsClass("PrevID") = PrevID
rsClass("NextID") = 0
rsClass("arrChildID") = CStr(rsClass("t_classid"))
If rsClass("ClassType") = 1 Then
rsClass("ParentDir") = sParentDir
End If
If PrevID <> rsClass("t_classid") And PrevID > 0 Then
Conn.Execute ("update t_area set NextID=" & rsClass("t_classid") & " where t_classid=" & PrevID & "")
End If
PrevID = rsClass("t_classid")
rsClass.Update
iOrderID = iOrderID + 1
Call UpdateClass(rsClass("t_classid"), iDepth + 1, ParentPath, sParentDir & rsClass("ClassDir") & "/", rsClass("ClassPurview"))
rsClass.MoveNext
Loop
End If
rsClass.Close
Set rsClass = Nothing
End Sub
Sub CheckClassDepth()
Dim strSql
strSql = "Select Depth from t_area Where ClassId=" & ParentID & ""
End Sub
Sub SaveAdd()
Dim ClassID, ClassName, ClassType, LinkUrl, ClassDir, ClassPicUrl, Tips, ReadMe, Meta_Keywords, Meta_Description
Dim ClassPurview, arrGroupID_Browse, arrGroupID_View, arrGroupID_Input, EnableComment, CheckComment
Dim PresentExp, DefaultItemPoint, DefaultItemChargeType, DefaultItemPitchTime, DefaultItemReadTimes, DefaultItemDividePercent
Dim OpenType, ShowOnTop, ShowOnIndex, IsElite, EnableAdd, EnableProtect, SkinID, TemplateID
Dim MaxPerPage, DefaultItemSkin, DefaultItemTemplate, ItemListOrderType, ItemOpenType
Dim sql, rs, trs, rsClass
Dim RootID, ParentDepth, ParentPath, ParentStr, ParentName, MaxClassID, MaxRootID, arrChildID, ParentDir, PrevOrderID
Dim PrevID, NextID, Child, strClassDir
Dim ReleaseClassPoint, CommandClassPoint '在菜单下发布信息要扣除的会员点数和设置菜单推荐要扣除的会员点数
ClassName = Trim(Request("ClassName"))
ClassType = CLng(Trim(Request("ClassType")))
LinkUrl = Trim(Request("LinkUrl"))
ClassPicUrl = Trim(Request("ClassPicUrl"))
Tips = Trim(Request("Tips"))
ReadMe = Trim(Request("Readme"))
OpenType = CLng(Trim(Request("OpenType")))
EnableAdd = CBool(Trim(Request("EnableAdd")))
If ClassName = "" Then
FoundErr = True
ErrMsg = ErrMsg & "
菜单名称不能为空！
"
Else
ClassName = ReplaceBadChar(ClassName)
End If
If ClassType > 1 Then
If LinkUrl = "" Then
FoundErr = True
ErrMsg = ErrMsg & "
链接地址不能为空！
"
End If
End If
If FoundErr = True Then
Exit Sub
End If
Set trs = Conn.Execute("Select * from t_area Where ChannelID=" & ChannelID & " and ParentID=" & ParentID & " AND ClassName='" & ClassName & "'")
If Not (trs.BOF And trs.EOF) Then
FoundErr = True
If ParentID = 0 Then
ErrMsg = ErrMsg & "
已经存在一级菜单：" & ClassName & "
"
Else
ErrMsg = ErrMsg & "
“" & ParentName & "”中已经存在子菜单“" & ClassName & "”！
"
End If
End If
trs.Close
Set trs = Nothing
If FoundErr = True Then
Exit Sub
End If
Set rs = Conn.Execute("select Max(t_classid) from t_area")
MaxClassID = rs(0)
If IsNull(MaxClassID) Then
MaxClassID = 0
End If
rs.Close
Set rs = Nothing
ClassID = MaxClassID + 1
Set rs = Conn.Execute("select max(rootid) from t_area where ChannelID=" & ChannelID & "")
MaxRootID = rs(0)
If IsNull(MaxRootID) Then
MaxRootID = 0
End If
rs.Close
Set rs = Nothing
RootID = MaxRootID + 1
If ParentID > 0 Then
Set rs = Conn.Execute("select * from t_area where t_classid=" & ParentID & "")
If rs.BOF And rs.EOF Then
FoundErr = True
ErrMsg = ErrMsg & "
所属菜单已经被删除！
"
rs.Close
Set rs = Nothing
Exit Sub
End If
If rs("ClassType") = 2 Then
FoundErr = True
ErrMsg = ErrMsg & "
不能指定外部菜单为所属菜单！
"
rs.Close
Set rs = Nothing
Exit Sub
End If
RootID = rs("RootID")
ParentName = rs("ClassName")
ParentDepth = rs("Depth")
ParentPath = rs("ParentPath") & "," & rs("t_classid") '得到此菜单的父级菜单路径
Child = rs("Child")
arrChildID = rs("arrChildID") & "," & ClassID
ParentDir = rs("ParentDir") & rs("ClassDir") & "/"
'更新本菜单的所有上级菜单的子菜单ID数组
Set trs = Conn.Execute("Select t_classid,arrChildID from t_area where t_classid in (" & ParentPath & ")")
Do While Not trs.EOF
Conn.Execute ("update t_area set arrChildID='" & trs(1) & "," & ClassID & "' where t_classid=" & trs(0))
trs.MoveNext
Loop
trs.Close
If Child > 0 Then
Dim rsPrevOrderID
'得到父菜单的所有子菜单中最后一个菜单的OrderID
Set rsPrevOrderID = Conn.Execute("select Max(OrderID) from t_area where t_classid in ( " & arrChildID & ")")
PrevOrderID = rsPrevOrderID(0)
Set rsPrevOrderID = Nothing
'得到本菜单的上一个菜单ID
Set trs = Conn.Execute("select t_ClassID from t_area where ChannelID=" & ChannelID & " and ParentID=" & ParentID & " order by OrderID desc limit 1")
PrevID = trs(0)
trs.Close
Else
PrevOrderID = rs("OrderID")
PrevID = 0
End If
rs.Close
Set rs = Nothing
Else
If MaxRootID > 0 Then
Set trs = Conn.Execute("Select t_classid from t_area where ChannelID=" & ChannelID & " and RootID=" & MaxRootID & " and Depth=0")
PrevID = trs(0)
trs.Close
Else
PrevID = 0
End If
PrevOrderID = 0
ParentPath = "0"
If ClassType = 1 Then
ParentDir = "/"
Else
ParentDir = ""
End If
End If
sql = "Select * from t_area where ChannelID=" & ChannelID & " order by t_classid desc limit 1"
Set rsClass = Server.CreateObject("adodb.recordset")
rsClass.Open sql, Conn, 1, 3
rsClass.addnew
rsClass("ChannelID") = ChannelID
rsClass("t_classid") = ClassID
rsClass("RootID") = RootID
rsClass("ParentID") = ParentID
If ParentID > 0 Then
rsClass("Depth") = ParentDepth + 1
Else
rsClass("Depth") = 0
End If
rsClass("ParentPath") = ParentPath
rsClass("OrderID") = PrevOrderID
rsClass("Child") = 0
rsClass("PrevID") = PrevID
rsClass("NextID") = 0
rsClass("arrChildID") = ClassID
rsClass("ItemCount") = 0
rsClass("ClassName") = ClassName
rsClass("ClassType") = ClassType
If ClassType > 1 Then
rsClass("LinkUrl") = LinkUrl
Else
rsClass("LinkUrl") = ""
End If
rsClass("ClassPicUrl") = ClassPicUrl
rsClass("Tips") = Tips
rsClass("Readme") = ReadMe
rsClass("OpenType") = OpenType
rsClass("EnableAdd") = EnableAdd
rsClass.Update
rsClass.Close
Set rsClass = Nothing
'更新与本菜单同一父菜单的上一个菜单的“NextID”字段值
If PrevID > 0 Then
Conn.Execute ("update t_area set NextID=" & ClassID & " where t_classid=" & PrevID)
End If
If ParentID > 0 Then
'更新其父类的子菜单数
Conn.Execute ("update t_area set child=child+1 where t_classid=" & ParentID)
'更新该菜单排序以及大于本需要和同在本分类下的菜单排序序号
Conn.Execute ("update t_area set OrderID=OrderID+1 where ChannelID=" & ChannelID & " and RootID=" & RootID & " and OrderID>" & PrevOrderID)
Conn.Execute ("update t_area set OrderID=" & PrevOrderID & "+1 where t_classid=" & ClassID)
End If
Call CloseConn
Response.Redirect "Admin_area.asp?ChannelID=" & ChannelID
End Sub
Sub SaveModify()
Dim ClassID, ClassName, ClassType, LinkUrl, ClassPicUrl, Tips, ReadMe, Meta_Keywords, Meta_Description
Dim ClassPurview, arrGroupID_Browse, arrGroupID_View, arrGroupID_Input, EnableComment, CheckComment
Dim PresentExp, DefaultItemPoint, DefaultItemChargeType, DefaultItemPitchTime, DefaultItemReadTimes, DefaultItemDividePercent
Dim OpenType, ShowOnTop, ShowOnIndex, IsElite, EnableAdd, EnableProtect, SkinID, TemplateID
Dim MaxPerPage, DefaultItemSkin, DefaultItemTemplate, ItemListOrderType, ItemOpenType
Dim sql, rsClass, i, trs
Dim ReleaseClassPoint, CommandClassPoint '在菜单下发布信息要扣除的会员点数和设置菜单推荐要扣除的会员点数
ClassID = Trim(Request("ClassID"))
If ClassID = "" Then
FoundErr = True
ErrMsg = ErrMsg & "
"
Else
ClassName = ReplaceBadChar(ClassName)
End If
If ClassType > 1 Then
If LinkUrl = "" Then
FoundErr = True
ErrMsg = ErrMsg & "
链接地址不能为空！
"
End If
End If
If FoundErr = True Then
Exit Sub
End If
sql = "select * from t_area where t_classid=" & ClassID
Set rsClass = Server.CreateObject("Adodb.recordset")
rsClass.Open sql, Conn, 1, 3
If rsClass.BOF And rsClass.EOF Then
FoundErr = True
ErrMsg = ErrMsg & "
找不到指定的菜单！
"
rsClass.Close
Set rsClass = Nothing
Exit Sub
End If
rsClass("ClassName") = ClassName
rsClass("ClassType") = ClassType
rsClass("LinkUrl") = LinkUrl
rsClass("ClassPicUrl") = ClassPicUrl
rsClass("Tips") = Tips
rsClass("Readme") = ReadMe
rsClass("OpenType") = OpenType
rsClass("EnableAdd") = EnableAdd
rsClass.Update
rsClass.Close
Set rsClass = Nothing
If FoundErr = True Then Exit Sub
Call CloseConn
Response.Redirect "Admin_area.asp?ChannelID=" & ChannelID
End Sub
Sub DeleteClass()
Dim sql, rsClass, trs, PrevID, NextID, ClassID, arrChildID, RootID, OrderID, strMsg, strListPath
ClassID = Trim(Request("ClassID"))
If ClassID = "" Then
FoundErr = True
ErrMsg = ErrMsg & "
参数不足！
"
Exit Sub
Else
ClassID = CLng(classid)
End If
sql = "Select t_classid,RootID,Depth,ParentID,arrChildID,Child,PrevID,NextID,OrderID,ClassType,ParentDir,ParentPath,ClassDir from t_area where t_classid=" & ClassID
Set rsClass = Conn.Execute(sql)
If rsClass.BOF And rsClass.EOF Then
FoundErr = True
ErrMsg = ErrMsg & "
菜单不存在，或者已经被删除
"
rsClass.Close
Set rsClass = Nothing
Exit Sub
End If
PrevID = rsClass("PrevID")
NextID = rsClass("NextID")
arrChildID = rsClass("arrChildID")
RootID = rsClass("RootID")
OrderID = rsClass("OrderID")
If rsClass("Depth") > 0 Then
Conn.Execute ("update t_area set child=child-1 where t_classid=" & rsClass("ParentID"))
'更新此菜单的原来所有上级菜单的子菜单ID数组
Set trs = Conn.Execute("Select t_classid,arrChildID from t_area where t_classid in (" & rsClass("ParentPath") & ")")
Do While Not trs.EOF
Conn.Execute ("update t_area set arrChildID='" & RemoveClassID(trs(1), arrChildID) & "' where t_classid=" & trs(0))
trs.MoveNext
Loop
trs.Close
'更新与此菜单同根且排序在其之下的菜单
Conn.Execute ("update t_area set OrderID=OrderID-" & UBound(Split(arrChildID, ",")) + 1 & " where ChannelID=" & ChannelID & " and RootID=" & RootID & " and OrderID>" & OrderID)
End If
'修改上一菜单的NextID和下一菜单的PrevID
If PrevID > 0 Then
Conn.Execute "update t_area set NextID=" & NextID & " where t_classid=" & PrevID
End If
If NextID > 0 Then
Conn.Execute "update t_area set PrevID=" & PrevID & " where t_classid=" & NextID
End If
rsClass.Close
Set rsClass = Nothing
'删除本菜单（包括子菜单）
Conn.Execute ("delete from t_area where ChannelID=" & ChannelID & " and t_ClassID in (" & arrChildID & ")")
If FoundErr <> True Then
Call CloseConn
Response.Redirect "Admin_area.asp?ChannelID=" & ChannelID
End If
End Sub
Sub DelClassDir(DirName)
On Error Resume Next
If ObjInstalled_FSO = False Or Trim(DirName) = "" Then Exit Sub
If fso.FolderExists(Server.MapPath(DirName)) Then
fso.DeleteFolder Server.MapPath(DirName)
If Err Then
Err.Clear
FoundErr = True
ErrMsg = ErrMsg & "
菜单目录无法自动删除！可能此目录中的文件正在使用中！请稍后使用FTP手动删除此目录。
"
End If
End If
End Sub
Sub ClearClass()
Dim rsClass, SuccessMsg, ClassID
ClassID = Trim(Request("ClassID"))
If ClassID = "" Then
FoundErr = True
ErrMsg = ErrMsg & "
参数不足！
"
Exit Sub
Else
ClassID = CLng(classid)
End If
Set rsClass = Conn.Execute("select arrChildID,ParentDir,ClassDir,ClassType from t_area where t_classid=" & ClassID)
If rsClass.BOF And rsClass.EOF Then
FoundErr = True
ErrMsg = ErrMsg & "
菜单不存在，或者已经被删除
"
Else
Conn.Execute ("update " & SheetName & " set Deleted=" & True & " where t_classid in (" & rsClass(0) & ")")
SuccessMsg = "此菜单（包括子菜单）的所有" & ChannelShortName & "已经被移到回收站中！"
If rsClass(3) = 1 And UseCreateHTML > 0 Then
Select Case StructureType
Case 0, 1, 2
Call ClearDir(HtmlDir & rsClass(1) & rsClass(2))
Case 3, 4, 5
Call ClearDir(HtmlDir & "/" & rsClass(2))
Case Else
Call DelInfo(rsClass(0))
End Select
End If
End If
rsClass.Close
Set rsClass = Nothing
If FoundErr = True Then Exit Sub
Call UpdateChannelData(ChannelID)
Call ClearSiteCache(0)
If UseCreateHTML > 0 Then
SuccessMsg = SuccessMsg & " 本菜单（包括子菜单）下的所有HTML文件已经被删除！你需要重新生成相关文件。"
Call WriteSuccessMsg(SuccessMsg, ComeUrl)
Else
Call CloseConn
Response.Redirect "Admin_area.asp?ChannelID=" & ChannelID
End If
End Sub
Sub ClearDir(DirName)
On Error Resume Next
Dim tmpDir, theFolder, theSubFolder
tmpDir = Server.MapPath(DirName)
If Not fso.FolderExists(tmpDir) Then
Exit Sub
End If
fso.DeleteFile tmpDir & "/*.*"
Set theFolder = fso.GetFolder(tmpDir)
For Each theSubFolder In theFolder.SubFolders
fso.DeleteFile tmpDir & "/" & theSubFolder.name & "/*.*"
Next
End Sub
Sub SaveMove()
Dim tChannelID, ClassID, sql, rsClass, i, rsPrevOrderID
Dim rParentID
Dim trs, rs, strMsg
Dim ParentID, RootID, Depth, Child, ParentPath, ParentName, iParentPath, PrevOrderID, PrevID, NextID, ClassCount
Dim ClassName, ClassType, ParentDir, tParentDir, cParentDir, arrChildID, ClassDir, CurrentDir, TargetDir
tChannelID = Trim(Request("tChannelID"))
ClassID = Trim(Request("ClassID"))
If ClassID = "" Then
FoundErr = True
ErrMsg = ErrMsg & "
参数不足！
"
Exit Sub
Else
ClassID = CLng(classid)
End If
sql = "select * from t_area where t_classid=" & ClassID
Set rsClass = Server.CreateObject("Adodb.recordset")
rsClass.Open sql, Conn, 1, 3
If rsClass.BOF And rsClass.EOF Then
FoundErr = True
ErrMsg = ErrMsg & "
找不到指定的菜单！
"
Else
Depth = rsClass("Depth")
Child = rsClass("Child")
RootID = rsClass("RootID")
ParentID = rsClass("ParentID")
ParentPath = rsClass("ParentPath")
PrevID = rsClass("PrevID")
NextID = rsClass("NextID")
ClassName = rsClass("ClassName")
arrChildID = rsClass("arrChildID")
ParentDir = rsClass("ParentDir")
ClassDir = rsClass("ClassDir")
ClassType = rsClass("ClassType")
End If
rsClass.Close
Set rsClass = Nothing
rParentID = CLng(Trim(Request("ParentID")))
If tChannelID = ChannelID Then
If rParentID = ClassID Then
FoundErr = True
ErrMsg = ErrMsg & "
所属菜单不能为自己！
"
Else
If rParentID = ParentID Then
FoundErr = True
ErrMsg = ErrMsg & "
目标菜单与当前父菜单相同，无需移动！
"
End If
End If
End If
If FoundErr = True Then Exit Sub
If rParentID > 0 Then
Set trs = Conn.Execute("Select t_classid from t_area where ChannelID=" & tChannelID & " and ClassType=1 and t_ClassID=" & rParentID)
If trs.BOF And trs.EOF Then
FoundErr = True
ErrMsg = ErrMsg & "
不能指定外部菜单为所属菜单
"
End If
trs.Close
Set trs = Nothing
If FoundInArr(arrChildID, rParentID, ",") = True Then
FoundErr = True
ErrMsg = ErrMsg & "
不能指定该菜单的下属菜单作为所属菜单
"
End If
End If
'检查目标菜单的子菜单中是否已经存在与此菜单名称相同的菜单
Set trs = Conn.Execute("Select t_classid,ClassDir from t_area where ChannelID=" & tChannelID & " and ParentID=" & rParentID & " and ClassName='" & ClassName & "'")
If Not (trs.BOF And trs.EOF) Then
FoundErr = True
ErrMsg = ErrMsg & "
目标菜单的子菜单中已经存在与此菜单名称相同的菜单。"
End If
Set trs = Nothing
If StructureType <= 1 Then
'检查目标菜单的子菜单中是否已经存在与此菜单目录相同的菜单
If ClassType = 1 Then
Set trs = Conn.Execute("Select t_classid,ParentDir from t_area where ChannelID=" & tChannelID & " and ParentID=" & rParentID & " and ClassDir='" & ClassDir & "'")
If Not (trs.BOF And trs.EOF) Then
FoundErr = True
ErrMsg = ErrMsg & "
目标菜单的子菜单中已经存在与此菜单目录相同的菜单。"
End If
Set trs = Nothing
End If
End If
If FoundErr = True Then
Exit Sub
End If
ClassCount = UBound(Split(arrChildID, ",")) + 1 '得到要移动的菜单数
CurrentDir = HtmlDir & ParentDir & ClassDir '得到当前目录
'需要更新其原来所属菜单信息，包括深度、父级ID、菜单数、排序等数据
'需要更新当前所属菜单信息
Dim mrs, MaxRootID
Set mrs = Conn.Execute("select max(rootid) from t_area where ChannelID=" & tChannelID & "")
MaxRootID = mrs(0)
Set mrs = Nothing
If IsNull(MaxRootID) Then
MaxRootID = 0
End If
'更新原来同一父菜单的上一个菜单的NextID和下一个菜单的PrevID
If PrevID > 0 Then
Conn.Execute "update t_area set NextID=" & NextID & " where t_classid=" & PrevID
End If
If NextID > 0 Then
Conn.Execute "update t_area set PrevID=" & PrevID & " where t_classid=" & NextID
End If
If ParentID = 0 And rParentID = 0 Then '如果原来是一级分类跨频道移到另一频道一级分类
'得到上一个一级分类菜单
sql = "Select t_classid,NextID from t_area where ChannelID=" & tChannelID & " and RootID=" & MaxRootID & " and Depth=0"
Set rs = Server.CreateObject("Adodb.recordset")
rs.Open sql, Conn, 1, 3
If rs.BOF And rs.EOF Then
PrevID = 0
Else
PrevID = rs(0) '得到新的PrevID
rs(1) = ClassID '更新上一个一级分类菜单的NextID的值
rs.Update
End If
rs.Close
Set rs = Nothing
MaxRootID = MaxRootID + 1
'更新当前菜单数据
Conn.Execute ("update t_area set ChannelID=" & tChannelID & ",rootid=" & MaxRootID & ",PrevID=" & PrevID & ",NextID=0 where t_classid=" & ClassID)
'如果有下属菜单，则更新其下属菜单数据。下属菜单的排序不需考虑，只需更新下属菜单深度和一级排序ID(rootid)数据
If Child > 0 Then
Conn.Execute ("update t_area set ChannelID=" & tChannelID & ",rootid=" & MaxRootID & " where t_classid in (" & arrChildID & ")")
End If
ElseIf ParentID > 0 And rParentID = 0 Then '如果原来不是一级分类改成一级分类
'更新其原来所属菜单的菜单数，排序相当于剪枝而不需考虑
Conn.Execute ("update t_area set child=child-1 where t_classid=" & ParentID)
'更新此菜单的原来所有上级菜单的子菜单ID数组
Set trs = Conn.Execute("Select t_classid,arrChildID from t_area where t_classid in (" & ParentPath & ")")
Do While Not trs.EOF
Conn.Execute ("update t_area set arrChildID='" & RemoveClassID(trs(1), arrChildID) & "' where t_classid=" & trs(0))
trs.MoveNext
Loop
trs.Close
'得到上一个一级分类菜单
sql = "Select t_classid,NextID from t_area where ChannelID=" & tChannelID & " and RootID=" & MaxRootID & " and Depth=0"
Set rs = Server.CreateObject("Adodb.recordset")
rs.Open sql, Conn, 1, 3
If rs.BOF And rs.EOF Then
PrevID = 0
Else
PrevID = rs(0) '得到新的PrevID
rs(1) = ClassID '更新上一个一级分类菜单的NextID的值
rs.Update
End If
rs.Close
Set rs = Nothing
MaxRootID = MaxRootID + 1
tParentDir = "/"
'更新当前菜单数据
Conn.Execute ("update t_area set ChannelID=" & tChannelID & ",depth=0,OrderID=0,rootid=" & MaxRootID & ",parentid=0,ParentPath='0',PrevID=" & PrevID & ",NextID=0,ParentDir='" & tParentDir & "' where t_classid=" & ClassID)
'如果有下属菜单，则更新其下属菜单数据。下属菜单的排序不需考虑，只需更新下属菜单深度和一级排序ID(rootid)数据
If Child > 0 Then
ParentPath = ParentPath & ","
arrChildID = RemoveClassID(arrChildID, ClassID) '从子菜单数组中去掉当前菜单的ID
Set rs = Conn.Execute("select * from t_area where t_classid in (" & arrChildID & ")")
Do While Not rs.EOF
iParentPath = Replace(rs("ParentPath"), ParentPath, "")
cParentDir = tParentDir & Right(rs("ParentDir"), Len(rs("ParentDir")) - Len(ParentDir))
Conn.Execute ("update t_area set ChannelID=" & tChannelID & ",depth=depth-" & Depth & ",rootid=" & MaxRootID & ",ParentPath='0," & iParentPath & "',ParentDir='" & cParentDir & "' where t_classid=" & rs("t_ClassID"))
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
End If
ElseIf ParentID > 0 And rParentID > 0 Then '如果是将一个分菜单移动到其他分菜单下
'更新其原父类的子菜单数
Conn.Execute ("update t_area set child=child-1 where t_classid=" & ParentID)
'更新此菜单的原来所有上级菜单的子菜单ID数组
Set trs = Conn.Execute("Select t_classid,arrChildID from t_area where t_classid in (" & ParentPath & ")")
Do While Not trs.EOF
Conn.Execute ("update t_area set arrChildID='" & RemoveClassID(trs(1), arrChildID) & "' where t_classid=" & trs(0))
trs.MoveNext
Loop
trs.Close
'获得目标菜单的相关信息
Set trs = Conn.Execute("select * from t_area where t_classid=" & rParentID)
tParentDir = trs("ParentDir") & trs("ClassDir") & "/"
If trs("Child") > 0 Then
'得到在目标菜单中与本菜单同级的最后一个菜单的ClassID，并更新其NextID的指向
Set rs = Conn.Execute("Select t_classid from t_area where ParentID=" & trs("t_ClassID") & " order by OrderID desc")
PrevID = rs(0) '得到新的PrevID
Conn.Execute ("update t_area set NextID=" & ClassID & " where t_classid=" & rs(0) & "")
Set rs = Nothing
'得到目标菜单的子菜单的最大OrderID
Set rsPrevOrderID = Conn.Execute("select Max(OrderID) from t_area where t_classid in (" & trs("arrChildID") & ")")
PrevOrderID = rsPrevOrderID(0)
Set rsPrevOrderID = Nothing
Else
PrevID = 0
PrevOrderID = trs("OrderID")
End If
'更新目标菜单的子菜单数
Conn.Execute ("update t_area set child=child+1 where t_classid=" & rParentID)
'更新目标菜单及目标菜单的所有上级菜单的子菜单ID数组
Set rs = Conn.Execute("Select t_classid,arrChildID from t_area where t_classid in (" & trs("ParentPath") & "," & trs("t_ClassID") & ")")
Do While Not rs.EOF
Conn.Execute ("update t_area set arrChildID='" & rs(1) & "," & arrChildID & "' where t_classid=" & rs(0))
rs.MoveNext
Loop
rs.Close
'在获得移动过来的菜单数后更新排序在指定菜单之后的菜单排序数据
Conn.Execute ("update t_area set OrderID=OrderID+" & ClassCount & "+1 where ChannelID=" & tChannelID & " and rootid=" & trs("rootid") & " and OrderID>" & PrevOrderID)
'更新当前菜单数据
Conn.Execute ("update t_area set ChannelID=" & tChannelID & ",depth=" & trs("depth") & "+1,OrderID=" & PrevOrderID & "+1,rootid=" & trs("rootid") & ",ParentID=" & rParentID & ",ParentPath='" & trs("ParentPath") & "," & trs("t_ClassID") & "',PrevID=" & PrevID & ",NextID=0,ParentDir='" & tParentDir & "' where t_classid=" & ClassID)
'如果当前菜单有子菜单则更新子菜单数据，深度为原来的相对深度加上当前所属菜单的深度
If Child > 0 Then
i = 1
arrChildID = RemoveClassID(arrChildID, ClassID) '从子菜单数组中去掉当前菜单的ID
ParentPath = ParentPath & ","
Set rs = Conn.Execute("select * from t_area where t_classid in (" & arrChildID & ") order by OrderID")
Do While Not rs.EOF
i = i + 1
iParentPath = trs("ParentPath") & "," & trs("t_ClassID") & "," & Replace(rs("ParentPath"), ParentPath, "")
cParentDir = tParentDir & Right(rs("ParentDir"), Len(rs("ParentDir")) - Len(ParentDir))
Conn.Execute ("update t_area set ChannelID=" & tChannelID & ",depth=depth-" & Depth & "+" & trs("depth") & "+1,OrderID=" & PrevOrderID & "+" & i & ",rootid=" & trs("rootid") & ",ParentPath='" & iParentPath & "',ParentDir='" & cParentDir & "' where t_classid=" & rs("t_ClassID"))
rs.MoveNext
Loop
rs.Close
End If
Set rs = Nothing
trs.Close
Set trs = Nothing
Else '如果原来是一级菜单改成其他菜单的下属菜单
'获得目标菜单的相关信息
Set trs = Conn.Execute("select * from t_area where t_classid=" & rParentID)
tParentDir = trs("ParentDir") & trs("ClassDir") & "/"
If trs("Child") > 0 Then
'得到在目标菜单中与本菜单同级的最后一个菜单的ClassID，并更新其NextID的指向
Set rs = Conn.Execute("Select t_classid from t_area where ParentID=" & trs("t_ClassID") & " order by OrderID desc")
PrevID = rs(0) '得到新的PrevID
Conn.Execute ("update t_area set NextID=" & ClassID & " where t_classid=" & rs(0) & "")
Set rs = Nothing
'得到目标菜单的子菜单的最大OrderID
Set rsPrevOrderID = Conn.Execute("select Max(OrderID) from t_area where t_classid in (" & trs("arrChildID") & ")")
PrevOrderID = rsPrevOrderID(0)
Set rsPrevOrderID = Nothing
Else
PrevID = 0
PrevOrderID = trs("OrderID")
End If
'更新目标菜单的子菜单数
Conn.Execute ("update t_area set child=child+1 where t_classid=" & rParentID)
'更新目标菜单及目标菜单的所有上级菜单的子菜单ID数组
Set rs = Conn.Execute("Select t_classid,arrChildID from t_area where t_classid in (" & trs("ParentPath") & "," & trs("t_ClassID") & ")")
Do While Not rs.EOF
Conn.Execute ("update t_area set arrChildID='" & rs(1) & "," & arrChildID & "' where t_classid=" & rs(0))
rs.MoveNext
Loop
rs.Close
'在获得移动过来的菜单数后更新排序在指定菜单之后的菜单排序数据
Conn.Execute ("update t_area set OrderID=OrderID+" & ClassCount & "+1 where ChannelID=" & tChannelID & " and rootid=" & trs("rootid") & " and OrderID>" & PrevOrderID)
'更新当前菜单数据
Conn.Execute ("update t_area set ChannelID=" & tChannelID & ",depth=depth+" & trs("depth") & "+1,OrderID=" & PrevOrderID + 1 & ",rootid=" & trs("rootid") & ",ParentPath='" & trs("ParentPath") & "," & trs("t_ClassID") & "',parentid=" & rParentID & ", PrevID=" & PrevID & ",NextID=0,ParentDir='" & tParentDir & "' where t_classid=" & ClassID & "")
'如果当前菜单有子菜单则更新子菜单数据，深度为原来的相对深度加上当前所属菜单的深度
Set rs = Conn.Execute("select * from t_area where ChannelID=" & ChannelID & " and rootid=" & RootID & " and ParentID>0 order by OrderID")
i = 1
Do While Not rs.EOF
i = i + 1
iParentPath = trs("ParentPath") & "," & trs("t_ClassID") & "," & Replace(rs("ParentPath"), "0,", "")
cParentDir = tParentDir & Right(rs("ParentDir"), Len(rs("ParentDir")) - Len(ParentDir))
Conn.Execute ("update t_area set ChannelID=" & tChannelID & ",depth=depth+" & trs("depth") & "+1,OrderID=" & PrevOrderID & "+" & i & ",rootid=" & trs("rootid") & ",ParentPath='" & iParentPath & "',ParentDir='" & cParentDir & "' where t_classid=" & rs("t_ClassID"))
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
trs.Close
Set trs = Nothing
End If
Call CloseConn
Response.Redirect "Admin_area.asp?ChannelID=" & ChannelID
End Sub
Sub MoveUpFilesToOtherChannel(tChannelID, tClassID)
Dim rsBatchMove, sqlBatchMove, ArticlePath
Dim rsChannel, tChannelDir, tUploadDir
Set rsChannel = Conn.Execute("select ChannelDir,UploadDir from Channel where ChannelID=" & tChannelID & "")
If rsChannel.BOF And rsChannel.EOF Then
FoundErr = True
ErrMsg = ErrMsg & "
找不到目标频道！
"
Else
tChannelDir = rsChannel("ChannelDir")
tUploadDir = rsChannel("UploadDir")
End If
Set rsChannel = Nothing
If FoundErr = True Then Exit Sub
Select Case ModuleType
Case 1
sqlBatchMove = "select UploadFiles from Article where t_classid in (" & tClassID & ")"
Case 2
sqlBatchMove = "select SoftPicUrl,DownloadUrl from Soft where t_classid in (" & tClassID & ")"
Case 3
sqlBatchMove = "select PhotoThumb,PhotoUrl from Photo where t_classid in (" & tClassID & ")"
End Select
Set rsBatchMove = Conn.Execute(sqlBatchMove)
Do While Not rsBatchMove.EOF
Select Case ModuleType
Case 1
Call MoveUpFiles(rsBatchMove("UploadFiles") & "", tChannelDir & "/" & tUploadDir) '移动上传文件
Case 2
Call MoveUpPic(rsBatchMove("SoftPicUrl"), tChannelDir)
Call MoveSoftUpFiles(rsBatchMove("DownloadUrl"), tChannelDir & "/" & tUploadDir) '移动上传文件
Case 3
Call MovePhotoUpFiles("缩略图|" & rsBatchMove("PhotoThumb") & "$$$" & rsBatchMove("PhotoUrl"), tChannelDir & "/" & tUploadDir) '移动上传文件
End Select
rsBatchMove.MoveNext
Loop
rsBatchMove.Close
Set rsBatchMove = Nothing
End Sub
Sub MoveUpFiles(strFiles, strTargetDir)
On Error Resume Next
Dim strTrueFile, arrFiles, strTrueDir, i
If IsNull(strFiles) Or strFiles = "" Or strTargetDir = "" Then Exit Sub
If Not fso.FolderExists(Server.MapPath(InstallDir & strTargetDir)) Then fso.CreateFolder Server.MapPath(InstallDir & strTargetDir)
arrFiles = Split(strFiles, "|")
For i = 0 To UBound(arrFiles)
strTrueDir = Server.MapPath(InstallDir & strTargetDir & "/" & Left(arrFiles(i), InStr(arrFiles(i), "/")))
If Not fso.FolderExists(strTrueDir) Then fso.CreateFolder strTrueDir
strTrueFile = Server.MapPath(InstallDir & ChannelDir & "/" & UploadDir & "/" & arrFiles(i))
If fso.FileExists(strTrueFile) Then
fso.MoveFile strTrueFile, Server.MapPath(InstallDir & strTargetDir & "/" & arrFiles(i))
End If
Next
End Sub
Sub MoveSoftUpFiles(strFiles, strTargetDir)
On Error Resume Next
Dim arrSoftUrls, strTrueFile, arrUrls, strTrueDir, iTemp
If strFiles = "" Or strTargetDir = "" Then Exit Sub
If Not fso.FolderExists(Server.MapPath(InstallDir & strTargetDir)) Then fso.CreateFolder Server.MapPath(InstallDir & strTargetDir)
arrSoftUrls = Split(strFiles, "$$$")
For iTemp = 0 To UBound(arrSoftUrls)
arrUrls = Split(arrSoftUrls(iTemp), "|")
If UBound(arrUrls) = 1 Then
If Left(arrUrls(1), 1) <> "/" And InStr(arrUrls(1), "://") <= 0 Then
strTrueDir = Server.MapPath(InstallDir & strTargetDir & "/" & Left(arrUrls(1), InStr(arrUrls(1), "/")))
If Not fso.FolderExists(strTrueDir) Then fso.CreateFolder strTrueDir
strTrueFile = Server.MapPath(InstallDir & ChannelDir & "/" & UploadDir & "/" & arrUrls(1))
If fso.FileExists(strTrueFile) Then
fso.MoveFile strTrueFile, Server.MapPath(InstallDir & strTargetDir & "/" & arrUrls(1))
End If
End If
End If
Next
End Sub
Sub MoveUpPic(strFile, strTargetDir)
On Error Resume Next
Dim strTrueFile, strTrueDir
If strFile = "" Or strTargetDir = "" Then Exit Sub
If Not fso.FolderExists(Server.MapPath(InstallDir & strTargetDir)) Then fso.CreateFolder Server.MapPath(InstallDir & strTargetDir)
If Left(strFile, 1) <> "/" And InStr(strFile, "://") <= 0 Then
strTrueDir = Server.MapPath(InstallDir & strTargetDir & "/" & Left(strFile, InStrRev(strFile, "/")))
If Not fso.FolderExists(strTrueDir) Then fso.CreateFolder strTrueDir
strTrueFile = Server.MapPath(InstallDir & ChannelDir & "/" & strFile)
If fso.FileExists(strTrueFile) Then
fso.MoveFile strTrueFile, Server.MapPath(InstallDir & strTargetDir & "/" & strFile)
End If
End If
End Sub
Sub MovePhotoUpFiles(strFiles, strTargetDir)
On Error Resume Next
Dim arrPhotoUrls, strTrueFile, arrUrls, strTrueDir, iTemp
If strFiles = "" Or strTargetDir = "" Then Exit Sub
If Not fso.FolderExists(Server.MapPath(InstallDir & strTargetDir)) Then fso.CreateFolder Server.MapPath(InstallDir & strTargetDir)
arrPhotoUrls = Split(strFiles, "$$$")
For iTemp = 0 To UBound(arrPhotoUrls)
arrUrls = Split(arrPhotoUrls(iTemp), "|")
If UBound(arrUrls) = 1 Then
If Left(arrUrls(1), 1) <> "/" And InStr(arrUrls(1), "://") <= 0 Then
strTrueDir = Server.MapPath(InstallDir & strTargetDir & "/" & Left(arrUrls(1), InStr(arrUrls(1), "/")))
If Not fso.FolderExists(strTrueDir) Then fso.CreateFolder strTrueDir
strTrueFile = Server.MapPath(InstallDir & ChannelDir & "/" & UploadDir & "/" & arrUrls(1))
If fso.FileExists(strTrueFile) Then
fso.MoveFile strTrueFile, Server.MapPath(InstallDir & strTargetDir & "/" & arrUrls(1))
End If
End If
End If
Next
End Sub
Sub UpOrder()
Dim ClassID, sqlOrder, rsOrder, MoveNum, cRootID, i, rs, PrevID, NextID
ClassID = Trim(Request("ClassID"))
cRootID = Trim(Request("cRootID"))
MoveNum = Trim(Request("MoveNum"))
If ClassID = "" Then
FoundErr = True
ErrMsg = ErrMsg & "
参数不足！
"
Else
ClassID = CLng(classid)
End If
If cRootID = "" Then
FoundErr = True
ErrMsg = ErrMsg & "
错误参数！
"
Else
cRootID = CLng(cRootID)
End If
If MoveNum = "" Then
FoundErr = True
ErrMsg = ErrMsg & "
错误参数！
"
Else
MoveNum = CLng(MoveNum)
If MoveNum = 0 Then
FoundErr = True
ErrMsg = ErrMsg & "
请选择要提升的数字！
"
End If
End If
If FoundErr = True Then
Exit Sub
End If
Dim mrs, MaxRootID, tRootID, tClassID, tOrderID, tPrevID
'得到本菜单的PrevID,NextID
Set rs = Conn.Execute("select PrevID,NextID from t_area where t_classid=" & ClassID)
PrevID = rs(0)
NextID = rs(1)
rs.Close
Set rs = Nothing
'先修改上一菜单的NextID和下一菜单的PrevID
If PrevID > 0 Then
Conn.Execute "update t_area set NextID=" & NextID & " where t_classid=" & PrevID
End If
If NextID > 0 Then
Conn.Execute "update t_area set PrevID=" & PrevID & " where t_classid=" & NextID
End If
'得到本频道最大RootID值
Set mrs = Conn.Execute("select max(rootid) from t_area where ChannelID=" & ChannelID & "")
MaxRootID = mrs(0) + 1
'先将当前菜单移至最后，包括子菜单
Conn.Execute ("update t_area set RootID=" & MaxRootID & " where ChannelID=" & ChannelID & " and RootID=" & cRootID)
'然后将位于当前菜单以上的菜单的RootID依次加一，范围为要提升的数字
sqlOrder = "select * from t_area where ChannelID=" & ChannelID & " and ParentID=0 and RootID<" & cRootID & " order by RootID desc"
Set rsOrder = Server.CreateObject("adodb.recordset")
rsOrder.Open sqlOrder, Conn, 1, 3
If rsOrder.BOF And rsOrder.EOF Then
Exit Sub '如果当前菜单已经在最上面，则无需移动
End If
i = 1
Do While Not rsOrder.EOF
tRootID = rsOrder("RootID") '得到要提升位置的RootID，包括子菜单
Conn.Execute ("update t_area set RootID=RootID+1 where ChannelID=" & ChannelID & " and RootID=" & tRootID)
i = i + 1
If i > MoveNum Then
tClassID = rsOrder("t_ClassID")
tPrevID = rsOrder("PrevID")
Exit Do
End If
rsOrder.MoveNext
Loop
rsOrder.Close
Set rsOrder = Nothing
'更新移动后本菜单的的PrevID和NextID，以及上一菜单的NextID和下一菜单的PrevID
Conn.Execute ("update t_area set PrevID=" & tPrevID & " where t_classid=" & ClassID)
Conn.Execute ("update t_area set NextID=" & tClassID & " where t_classid=" & ClassID)
Conn.Execute ("update t_area set PrevID=" & ClassID & " where t_classid=" & tClassID)
If tPrevID > 0 Then
Conn.Execute ("update t_area set NextID=" & ClassID & " where t_classid=" & tPrevID)
End If
'然后再将当前菜单从最后移到相应位置，包括子菜单
Conn.Execute ("update t_area set RootID=" & tRootID & " where ChannelID=" & ChannelID & " and RootID=" & MaxRootID)
Call CloseConn
Response.Redirect "Admin_area.asp?ChannelID=" & ChannelID & "&Action=Order"
End Sub
Sub DownOrder()
Dim ClassID, sqlOrder, rsOrder, MoveNum, cRootID, i, rs, PrevID, NextID
ClassID = Trim(Request("ClassID"))
cRootID = Trim(Request("cRootID"))
MoveNum = Trim(Request("MoveNum"))
If ClassID = "" Then
FoundErr = True
ErrMsg = ErrMsg & "
参数不足！
"
Else
ClassID = CLng(classid)
End If
If cRootID = "" Then
FoundErr = True
ErrMsg = ErrMsg & "
错误参数！
"
Else
cRootID = CLng(cRootID)
End If
If MoveNum = "" Then
FoundErr = True
ErrMsg = ErrMsg & "
错误参数！
"
Else
MoveNum = CLng(MoveNum)
If MoveNum = 0 Then
FoundErr = True
ErrMsg = ErrMsg & "
请选择要提升的数字！
"
End If
End If
If FoundErr = True Then
Exit Sub
End If
Dim mrs, MaxRootID, tRootID, tClassID, tOrderID, tNextID
'得到本菜单的PrevID,NextID
Set rs = Conn.Execute("select PrevID,NextID from t_area where t_classid=" & ClassID)
PrevID = rs(0)
NextID = rs(1)
rs.Close
Set rs = Nothing
'先修改上一菜单的NextID和下一菜单的PrevID
If PrevID > 0 Then
Conn.Execute "update t_area set NextID=" & NextID & " where t_classid=" & PrevID
End If
If NextID > 0 Then
Conn.Execute "update t_area set PrevID=" & PrevID & " where t_classid=" & NextID
End If
'得到本频道最大RootID值
Set mrs = Conn.Execute("select max(rootid) from t_area where ChannelID=" & ChannelID & "")
MaxRootID = mrs(0) + 1
'先将当前菜单移至最后，包括子菜单
Conn.Execute ("update t_area set RootID=" & MaxRootID & " where ChannelID=" & ChannelID & " and RootID=" & cRootID)
'然后将位于当前菜单以下的菜单的RootID依次减一，范围为要下降的数字
sqlOrder = "select * from t_area where ChannelID=" & ChannelID & " and ParentID=0 and RootID>" & cRootID & " order by RootID"
Set rsOrder = Server.CreateObject("adodb.recordset")
rsOrder.Open sqlOrder, Conn, 1, 3
If rsOrder.BOF And rsOrder.EOF Then
Exit Sub '如果当前菜单已经在最下面，则无需移动
End If
i = 1
Do While Not rsOrder.EOF
tRootID = rsOrder("RootID") '得到要提升位置的RootID，包括子菜单
Conn.Execute ("update t_area set RootID=RootID-1 where ChannelID=" & ChannelID & " and RootID=" & tRootID)
i = i + 1
If i > MoveNum Then
tClassID = rsOrder("t_ClassID")
tNextID = rsOrder("NextID")
Exit Do
End If
rsOrder.MoveNext
Loop
rsOrder.Close
Set rsOrder = Nothing
'更新移动后本菜单的的PrevID和NextID，以及上一菜单的NextID和下一菜单的PrevID
Conn.Execute ("update t_area set PrevID=" & tClassID & " where t_classid=" & ClassID)
Conn.Execute ("update t_area set NextID=" & tNextID & " where t_classid=" & ClassID)
Conn.Execute ("update t_area set NextID=" & ClassID & " where t_classid=" & tClassID)
If tNextID > 0 Then
Conn.Execute ("update t_area set PrevID=" & ClassID & " where t_classid=" & tNextID)
End If
'然后再将当前菜单从最后移到相应位置，包括子菜单
Conn.Execute ("update t_area set RootID=" & tRootID & " where ChannelID=" & ChannelID & " and RootID=" & MaxRootID)
Call CloseConn
Response.Redirect "Admin_area.asp?ChannelID=" & ChannelID & "&Action=Order"
End Sub
Sub UpOrderN()
Dim sqlOrder, rsOrder, MoveNum, ClassID, i
Dim ParentID, OrderID, ParentPath, Child, PrevID, NextID
ClassID = Trim(Request("ClassID"))
MoveNum = Trim(Request("MoveNum"))
If ClassID = "" Then
FoundErr = True
ErrMsg = ErrMsg & "
错误参数！
"
Else
ClassID = CLng(classid)
End If
If MoveNum = "" Then
FoundErr = True
ErrMsg = ErrMsg & "
错误参数！
"
Else
MoveNum = CLng(MoveNum)
If MoveNum = 0 Then
FoundErr = True
ErrMsg = ErrMsg & "
请选择要提升的数字！
"
End If
End If
If FoundErr = True Then
Exit Sub
End If
Dim sql, rs, trs, AddOrderNum, tClassID, tOrderID, tPrevID
'要移动的菜单信息
Set rs = Conn.Execute("select ParentID,OrderID,ParentPath,Child,PrevID,NextID from t_area where t_classid=" & ClassID)
ParentID = rs(0)
OrderID = rs(1)
ParentPath = rs(2) & "," & ClassID
Child = rs(3)
PrevID = rs(4)
NextID = rs(5)
rs.Close
Set rs = Nothing
'获得要移动的菜单的所有子菜单数，然后加1（菜单本身），得到排序增加数（即其上菜单的OrderID增加数AddOrderNum）
If Child > 0 Then
Set rs = Conn.Execute("select count(*) from t_area where ParentPath like '%" & ParentPath & "%'")
AddOrderNum = CLng(rs(0)) + 1
rs.Close
Set rs = Nothing
Else
AddOrderNum = 1
End If
'先修改上一菜单的NextID和下一菜单的PrevID
If PrevID > 0 Then
Conn.Execute "update t_area set NextID=" & NextID & " where t_classid=" & PrevID
End If
If NextID > 0 Then
Conn.Execute "update t_area set PrevID=" & PrevID & " where t_classid=" & NextID
End If
'和该菜单同级且排序在其之上的菜单------更新其排序，范围为要提升的数字AddOrderNum
sql = "Select t_classid,OrderID,Child,ParentPath,PrevID,NextID from t_area where ParentID=" & ParentID & " and OrderID<" & OrderID & " order by OrderID desc"
Set rs = Server.CreateObject("adodb.recordset")
rs.Open sql, Conn, 1, 3
i = 0
Do While Not rs.EOF
tOrderID = rs(1)
Conn.Execute ("update t_area set OrderID=OrderID+" & AddOrderNum & " where t_classid=" & rs(0))
If rs(2) > 0 Then
Set trs = Conn.Execute("Select t_classid,OrderID from t_area where ParentPath like '%" & rs(3) & "," & rs(0) & "%' order by OrderID")
If Not (trs.BOF And trs.EOF) Then
Do While Not trs.EOF
Conn.Execute ("update t_area set OrderID=OrderID+" & AddOrderNum & " where t_classid=" & trs(0))
trs.MoveNext
Loop
End If
trs.Close
Set trs = Nothing
End If
i = i + 1
If i >= MoveNum Then
'获得最后一个提升序号的同级菜单信息
tClassID = rs(0)
tPrevID = rs(4)
Exit Do
End If
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
'更新移动后本菜单的的PrevID和NextID，以及上一菜单的NextID和下一菜单的PrevID
Conn.Execute ("update t_area set PrevID=" & tPrevID & " where t_classid=" & ClassID)
Conn.Execute ("update t_area set NextID=" & tClassID & " where t_classid=" & ClassID)
Conn.Execute ("update t_area set PrevID=" & ClassID & " where t_classid=" & tClassID)
If tPrevID > 0 Then
Conn.Execute ("update t_area set NextID=" & ClassID & " where t_classid=" & tPrevID)
End If
'更新所要排序的菜单的序号
Conn.Execute ("update t_area set OrderID=" & tOrderID & " where t_classid=" & ClassID)
'如果有下属菜单，则更新其下属菜单排序
If Child > 0 Then
i = 1
Set rs = Conn.Execute("Select t_classid from t_area where ParentPath like '%" & ParentPath & "%' order by OrderID")
Do While Not rs.EOF
Conn.Execute ("update t_area set OrderID=" & tOrderID + i & " where t_classid=" & rs(0))
i = i + 1
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
End If
Call CloseConn
Response.Redirect "Admin_area.asp?ChannelID=" & ChannelID & "&Action=OrderN"
End Sub
Sub DownOrderN()
Dim sqlOrder, rsOrder, MoveNum, ClassID, i
Dim ParentID, OrderID, ParentPath, Child, PrevID, NextID
ClassID = Trim(Request("ClassID"))
MoveNum = Trim(Request("MoveNum"))
If ClassID = "" Then
FoundErr = True
ErrMsg = ErrMsg & "
错误参数！
"
Exit Sub
Else
ClassID = CLng(classid)
End If
If MoveNum = "" Then
FoundErr = True
ErrMsg = ErrMsg & "
错误参数！
"
Exit Sub
Else
MoveNum = CLng(MoveNum)
If MoveNum = 0 Then
FoundErr = True
ErrMsg = ErrMsg & "
请选择要下降的数字！
"
Exit Sub
End If
End If
Dim sql, rs, trs, ii, tClassID, tNextID
'要移动的菜单信息
Set rs = Conn.Execute("select ParentID,OrderID,ParentPath,child,PrevID,NextID from t_area where t_classid=" & ClassID)
ParentID = rs(0)
OrderID = rs(1)
ParentPath = rs(2) & "," & ClassID
Child = rs(3)
PrevID = rs(4)
NextID = rs(5)
rs.Close
Set rs = Nothing
'先修改上一菜单的NextID和下一菜单的PrevID
If PrevID > 0 Then
Conn.Execute "update t_area set NextID=" & NextID & " where t_classid=" & PrevID
End If
If NextID > 0 Then
Conn.Execute "update t_area set PrevID=" & PrevID & " where t_classid=" & NextID
End If
'和该菜单同级且排序在其之下的菜单------更新其排序，范围为要下降的数字
sql = "Select t_classid,OrderID,child,ParentPath,PrevID,NextID from t_area where ParentID=" & ParentID & " and OrderID>" & OrderID & " order by OrderID"
Set rs = Server.CreateObject("adodb.recordset")
rs.Open sql, Conn, 1, 3
i = 0 '同级菜单
ii = 0 '同级菜单和子菜单
Do While Not rs.EOF
Conn.Execute ("update t_area set OrderID=" & OrderID + ii & " where t_classid=" & rs(0))
If rs(2) > 0 Then
Set trs = Conn.Execute("Select t_classid,OrderID from t_area where ParentPath like '%" & rs(3) & "," & rs(0) & "%' order by OrderID")
If Not (trs.BOF And trs.EOF) Then
Do While Not trs.EOF
ii = ii + 1
Conn.Execute ("update t_area set OrderID=" & OrderID + ii & " where t_classid=" & trs(0))
trs.MoveNext
Loop
End If
trs.Close
Set trs = Nothing
End If
ii = ii + 1
i = i + 1
If i >= MoveNum Then
'获得移动后本菜单的上一菜单的信息
tClassID = rs(0)
tNextID = rs(5)
Exit Do
End If
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
'更新移动后本菜单的的PrevID和NextID，以及上一菜单的NextID和下一菜单的PrevID
Conn.Execute ("update t_area set PrevID=" & tClassID & " where t_classid=" & ClassID)
Conn.Execute ("update t_area set NextID=" & tNextID & " where t_classid=" & ClassID)
Conn.Execute ("update t_area set NextID=" & ClassID & " where t_classid=" & tClassID)
If tNextID > 0 Then
Conn.Execute ("update t_area set PrevID=" & ClassID & " where t_classid=" & tNextID)
End If
'更新所要排序的菜单的序号
Conn.Execute ("update t_area set OrderID=" & OrderID + ii & " where t_classid=" & ClassID)
'如果有下属菜单，则更新其下属菜单排序
If Child > 0 Then
i = 1
Set rs = Conn.Execute("Select t_classid from t_area where ParentPath like '%" & ParentPath & "%' order by OrderID")
Do While Not rs.EOF
Conn.Execute ("update t_area set OrderID=" & OrderID + ii + i & " where t_classid=" & rs(0))
i = i + 1
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
End If
Call CloseConn
Response.Redirect "Admin_area.asp?ChannelID=" & ChannelID & "&Action=OrderN"
End Sub
Sub SaveReset()
Dim i, sql, rsClass, SuccessMsg, iCount, PrevID, NextID, ClassDir, trs
sql = "Select t_classid,ParentID,ClassType,ParentDir,ClassDir from t_area where ChannelID=" & ChannelID & " order by RootID,OrderID"
Set rsClass = Server.CreateObject("adodb.recordset")
rsClass.Open sql, Conn, 1, 1
iCount = rsClass.RecordCount
i = 1
PrevID = 0
Do While Not rsClass.EOF
rsClass.MoveNext
If rsClass.EOF Then
NextID = 0
Else
NextID = rsClass(0)
End If
rsClass.moveprevious
Set trs = Conn.Execute("select Count(t_classid) from t_area where ChannelID=" & ChannelID & " and ParentID=0 and t_ClassID<>" & rsClass(0) & " and ClassDir='" & rsClass(4) & "'")
If trs(0) > 1 Then
ClassDir = rsClass(4) & rsClass(0)
Else
ClassDir = rsClass(4)
End If
Set trs = Nothing
Conn.Execute ("update t_area set RootID=" & i & ",OrderID=0,ParentID=0,Child=0,ParentPath='0',Depth=0,PrevID=" & PrevID & ",NextID=" & NextID & ",arrChildID='" & rsClass(0) & "',ParentDir='/',ClassDir='" & ClassDir & "' where t_classid=" & rsClass(0))
PrevID = rsClass(0)
i = i + 1
rsClass.MoveNext
Loop
rsClass.Close
Set rsClass = Nothing
If FoundErr = True Then
Call WriteErrMsg(ErrMsg, ComeUrl)
Else
SuccessMsg = "复位成功！请返回菜单管理首页做菜单的归属设置。"
Call WriteSuccessMsg(SuccessMsg, ComeUrl)
End If
End Sub
Sub ResetChildClass()
Dim ClassID, RootID, ParentPath, ParentDir, ClassDir
Dim sql, rsClass, SuccessMsg, iCount, PrevID, NextID, i, trs
ClassID = Trim(Request("ClassID"))
If ClassID = "" Then
FoundErr = True
ErrMsg = ErrMsg & "
参数不足！
"
Exit Sub
Else
ClassID = CLng(classid)
End If
Set rsClass = Conn.Execute("Select t_classid,RootID,ClassDir from t_area where ChannelID=" & ChannelID & " and ParentID=0 and t_ClassID=" & ClassID)
If rsClass.BOF And rsClass.EOF Then
FoundErr = True
ErrMsg = ErrMsg & "
找不到指定的菜单！
"
Else
RootID = rsClass(1)
ParentPath = "0," & rsClass(0)
ParentDir = "/" & rsClass(2) & "/"
End If
Set rsClass = Nothing
If FoundErr = True Then Exit Sub
sql = "Select t_classid,ParentID,ClassType,ParentDir,ClassDir from t_area where ChannelID=" & ChannelID & " and RootID=" & RootID & " and ParentID>0 order by OrderID"
Set rsClass = Server.CreateObject("adodb.recordset")
rsClass.Open sql, Conn, 1, 1
iCount = rsClass.RecordCount
i = 1
PrevID = 0
Do While Not rsClass.EOF
rsClass.MoveNext
If rsClass.EOF Then
NextID = 0
Else
NextID = rsClass(0)
End If
rsClass.moveprevious
Set trs = Conn.Execute("select Count(t_classid) from t_area where ChannelID=" & ChannelID & " and ParentID=" & ClassID & " and t_ClassID<>" & rsClass(0) & " and ClassDir='" & rsClass(4) & "'")
If trs(0) > 1 Then
ClassDir = rsClass(4) & rsClass(0)
Else
ClassDir = rsClass(4)
End If
Set trs = Nothing
Conn.Execute ("update t_area set OrderID=" & i & ",ParentID=" & ClassID & ",Child=0,ParentPath='" & ParentPath & "',Depth=1,PrevID=" & PrevID & ",NextID=" & NextID & ",arrChildID='" & rsClass(0) & "',ParentDir='" & ParentDir & "',ClassDir='" & ClassDir & "' where t_classid=" & rsClass(0))
PrevID = rsClass(0)
i = i + 1
rsClass.MoveNext
Loop
rsClass.Close
Set rsClass = Nothing
Conn.Execute ("update t_area set Child=" & i - 1 & " where t_classid=" & ClassID)
SuccessMsg = "复位成功！请返回菜单管理首页做菜单的归属设置。"
Call WriteSuccessMsg(SuccessMsg, ComeUrl)
End Sub
Sub SaveUnite()
Dim ClassID, TargetClassID, ParentID, ParentPath, Depth, Child, PrevID, NextID, arrChildID
Dim rsClass, trs, i, SuccessMsg
ClassID = Trim(Request("ClassID"))
TargetClassID = Trim(Request("TargetClassID"))
If ClassID = "" Then
FoundErr = True
ErrMsg = ErrMsg & "
请指定要合并的菜单！
"
Else
ClassID = CLng(classid)
End If
If TargetClassID = "" Then
FoundErr = True
ErrMsg = ErrMsg & "
请指定目标菜单！
"
Else
TargetClassID = CLng(TargetClassID)
End If
If ClassID = TargetClassID Then
FoundErr = True
ErrMsg = ErrMsg & "
请不要在相同菜单内进行操作
"
End If
If FoundErr = True Then
Exit Sub
End If
'判断目标菜单是否为外部菜单及是否有子菜单
Set rsClass = Conn.Execute("Select t_classid,Child,ClassType from t_area where t_classid=" & TargetClassID)
If rsClass.BOF And rsClass.EOF Then
FoundErr = True
ErrMsg = ErrMsg & "
目标菜单不存在，可能已经被删除！
"
Else
If rsClass(1) > 0 Then
FoundErr = True
ErrMsg = ErrMsg & "
目标菜单中含有子菜单，不能合并！
"
End If
If rsClass(2) = 2 Then
FoundErr = True
ErrMsg = ErrMsg & "
目标菜单是外部菜单，不能合并！
"
End If
End If
Set rsClass = Nothing
If FoundErr = True Then
Exit Sub
End If
'得到当前菜单信息
Set rsClass = Conn.Execute("Select t_classid,ParentID,ParentPath,Depth,PrevID,NextID,arrChildID,ParentDir,ClassDir,ClassType from t_area where t_classid=" & ClassID)
If rsClass.BOF And rsClass.EOF Then
FoundErr = True
ErrMsg = ErrMsg & "
找不到指定的菜单，可能已经被删除！
"
rsClass.Close
Set rsClass = Nothing
Exit Sub
End If
ParentID = rsClass(1)
ParentPath = rsClass(2)
Depth = rsClass(3)
PrevID = rsClass(4)
NextID = rsClass(5)
arrChildID = rsClass(6)
'判断是否是合并到其下属菜单中
Set trs = Conn.Execute("Select t_classid from t_area where t_classid=" & TargetClassID & " and t_ClassID in (" & arrChildID & ")")
If Not (trs.BOF And trs.EOF) Then
FoundErr = True
ErrMsg = ErrMsg & "
不能将一个菜单合并到其下属子菜单中
"
End If
Set trs = Nothing
If FoundErr = True Then
Set rsClass = Nothing
Exit Sub
End If
Set rsClass = Nothing
Conn.Execute ("update t_dev_property set areaid = '" & TargetClassID & "' where areaid in (" & arrChildID & ")")
'先修改上一菜单的NextID和下一菜单的PrevID
If PrevID > 0 Then
Conn.Execute "update t_area set NextID=" & NextID & " where t_classid=" & PrevID
End If
If NextID > 0 Then
Conn.Execute "update t_area set PrevID=" & PrevID & " where t_classid=" & NextID
End If
'删除被合并菜单及其下属菜单
Conn.Execute ("delete from t_area where ChannelID=" & ChannelID & " and t_ClassID in (" & arrChildID & ")")
'更新其原来所属菜单的子菜单数，排序相当于剪枝而不需考虑
If ParentID > 0 Then
Conn.Execute ("update t_area set Child=Child-1 where t_classid=" & ParentID)
'更新此菜单的原来所有上级菜单的子菜单ID数组
Set trs = Conn.Execute("Select t_classid,arrChildID from t_area where t_classid in (" & ParentPath & ")")
Do While Not trs.EOF
Conn.Execute ("update t_area set arrChildID='" & RemoveClassID(trs(1), arrChildID) & "' where t_classid=" & trs(0))
trs.MoveNext
Loop
trs.Close
Set trs = Nothing
End If
SuccessMsg = "菜单合并成功！已经将被合并菜单及其下属子菜单的所有数据转入目标菜单中。
同时删除了被合并的菜单及其子菜单。"
Call WriteSuccessMsg(SuccessMsg, ComeUrl)
End Sub
Sub DoBatch()
Dim ClassID, ClassPurview, arrGroupID_Browse, arrGroupID_View, arrGroupID_Input, EnableComment, CheckComment
Dim PresentExp, DefaultItemPoint, DefaultItemChargeType, DefaultItemPitchTime, DefaultItemReadTimes, DefaultItemDividePercent
Dim OpenType, ShowOnTop, ShowOnIndex, IsElite, EnableAdd, EnableProtect, SkinID, TemplateID
Dim MaxPerPage, DefaultItemSkin, DefaultItemTemplate, ItemListOrderType, ItemOpenType
Dim sql, rsClass, i
Dim CommandClassPoint, ReleaseClassPoint
ClassID = Trim(Request("ClassID"))
OpenType = CLng(Trim(Request("OpenType")))
EnableAdd = CBool(Trim(Request("EnableAdd")))
If IsValidID(t_classid) = False Then
FoundErr = True
ErrMsg = ErrMsg & "
请先选定要批量修改设置的菜单！
"
Else
ClassID = ReplaceBadChar(t_classid)
End If
If FoundErr = True Then
Exit Sub
End If
sql = "select * from t_area where ChannelID=" & ChannelID & " and t_ClassID in (" & ClassID & ")"
Set rsClass = Server.CreateObject("Adodb.recordset")
rsClass.Open sql, Conn, 1, 3
Do While Not rsClass.EOF
If Trim(Request("ModifyOpenType")) = "Yes" Then rsClass("OpenType") = OpenType
If Trim(Request("ModifyEnableAdd")) = "Yes" Then rsClass("EnableAdd") = EnableAdd
rsClass.Update
rsClass.MoveNext
Loop
rsClass.Close
Set rsClass = Nothing
Dim msg
msg = "批量设置菜单属性成功！"
Call WriteSuccessMsg(msg, ComeUrl)
End Sub
Function RemoveClassID(ByVal arrClassID_Parent, ByVal arrClassID_Child)
Dim arrClassID, arrClassID2, arrClassID3, i, j, bFound
If IsNull(arrClassID_Parent) Then
RemoveClassID = ""
Exit Function
End If
If IsNull(arrClassID_Parent) Then
RemoveClassID = arrClassID_Parent
Exit Function
End If
If Trim(arrClassID_Parent) = Trim(arrClassID_Child) Then
RemoveClassID = ""
Exit Function
End If
arrClassID = Split(arrClassID_Parent, ",")
arrClassID3 = ""
If InStr(arrClassID_Child, ",") > 0 Then
arrClassID2 = Split(arrClassID_Child, ",")
For i = 0 To UBound(arrClassID)
bFound = False
For j = 0 To UBound(arrClassID2)
If CLng(arrClassID(i)) = CLng(arrClassID2(j)) Then
bFound = True
Exit For
End If
Next
If bFound = False Then
If arrClassID3 = "" Then
arrClassID3 = arrClassID(i)
Else
arrClassID3 = arrClassID3 & "," & arrClassID(i)
End If
End If
Next
Else
For i = 0 To UBound(arrClassID)
If CLng(arrClassID(i)) <> CLng(arrClassID_Child) Then
If arrClassID3 = "" Then
arrClassID3 = arrClassID(i)
Else
arrClassID3 = arrClassID3 & "," & arrClassID(i)
End If
End If
Next
End If
RemoveClassID = arrClassID3
End Function
Sub CreateJS_Class()
If ObjInstalled_FSO = False Then
Exit Sub
End If
Dim hf, strTopMenu, strClassTree, strNavigation, strOption, strForm, TopMenuType
Select Case TopMenuType
Case 0, 1
strTopMenu = GetRootClass_Menu()
Case 2
strTopMenu = "var h,w,l,t;" & vbCrLf
strTopMenu = strTopMenu & "var topMar = 1;" & vbCrLf
strTopMenu = strTopMenu & "var leftMar = -2;" & vbCrLf
strTopMenu = strTopMenu & "var space = 1;" & vbCrLf
strTopMenu = strTopMenu & "var isvisible;" & vbCrLf
strTopMenu = strTopMenu & "var MENU_SHADOW_COLOR='#999999';" & vbCrLf
strTopMenu = strTopMenu & "var global = window.document" & vbCrLf
strTopMenu = strTopMenu & "global.fo_currentMenu = null" & vbCrLf
strTopMenu = strTopMenu & "global.fo_shadows = new Array" & vbCrLf
strTopMenu = strTopMenu & GetJS_ClassMenu() & vbCrLf
strTopMenu = strTopMenu & "document.write(" & Chr(34) & GetRootClass(1) & Chr(34) & ");"
Case 3
strTopMenu = "document.write(" & Chr(34) & GetRootClass(2) & Chr(34) & ");"
End Select
If Not fso.FolderExists(Server.MapPath(InstallDir & ChannelDir & "/js")) Then
fso.CreateFolder Server.MapPath(InstallDir & ChannelDir & "/js")
End If
Call WriteToFile(InstallDir & ChannelDir & "/js/ShowClass_Menu.js", strTopMenu)
strClassTree = GetClass_Tree()
Call WriteToFile(InstallDir & ChannelDir & "/js/ShowClass_Tree.js", "document.write(""" & strClassTree & """);")
Select Case ClassGuideType
Case 1
strNavigation = "document.write(""" & GetClass_Navigation(1, 0, 2) & """);"
Case 2
strNavigation = "document.write(""" & GetClass_Navigation(1, 0, 3) & """);"
Case 3
strNavigation = "document.write(""" & GetClass_Navigation(1, 0, 4) & """);"
Case 4
strNavigation = "document.write(""" & GetClass_Navigation(1, 0, 5) & """);"
Case 5
strNavigation = "document.write(""" & GetClass_Navigation(1, 0, 6) & """);"
Case 6
strNavigation = "document.write(""" & GetClass_Navigation(1, 0, 7) & """);"
Case 7
strNavigation = "document.write(""" & GetClass_Navigation(1, 0, 8) & """);"
Case 8
strNavigation = "document.write(""" & GetClass_Navigation(2, 1, 2) & """);"
Case 9
strNavigation = "document.write(""" & GetClass_Navigation(2, 1, 3) & """);"
Case 10
strNavigation = "document.write(""" & GetClass_Navigation(2, 1, 4) & """);"
Case 11
strNavigation = "document.write(""" & GetClass_Navigation(2, 1, 5) & """);"
Case 12
strNavigation = "document.write(""" & GetClass_Navigation(2, 1, 6) & """);"
Case 13
strNavigation = "document.write(""" & GetClass_Navigation(2, 1, 7) & """);"
Case 14
strNavigation = "document.write(""" & GetClass_Navigation(2, 1, 8) & """);"
Case 15
strNavigation = "document.write(""" & GetClass_Navigation(2, 2, 2) & """);"
Case 16
strNavigation = "document.write(""" & GetClass_Navigation(2, 2, 3) & """);"
Case 17
strNavigation = "document.write(""" & GetClass_Navigation(2, 2, 4) & """);"
Case 18
strNavigation = "document.write(""" & GetClass_Navigation(2, 2, 5) & """);"
Case 19
strNavigation = "document.write(""" & GetClass_Navigation(2, 2, 6) & """);"
End Select
Call WriteToFile(InstallDir & ChannelDir & "/js/ShowClass_Navigation.js", strNavigation)
strOption = GetClass_Option(ChannelID, 0)
Call WriteToFile(InstallDir & ChannelDir & "/js/ShowClass_Option.js", "document.write(""" & strOption & """);")
strForm = ShowSearchForm(2, 0)
Call WriteToFile(InstallDir & ChannelDir & "/js/ShowSearchForm.js", "document.write(""" & strForm & """);")
End Sub
Function GetClass_Option(iChannelID, CurrentID)
Dim rsClass, sqlClass, strTemp, tmpDepth, i
Dim arrShowLine(20)
For i = 0 To UBound(arrShowLine)
arrShowLine(i) = False
Next
sqlClass = "Select t_classid,ClassName,ClassType,Depth,NextID from t_area where ChannelID=" & iChannelID & " order by RootID,OrderID"
Set rsClass = Conn.Execute(sqlClass)
If rsClass.BOF And rsClass.EOF Then
strTemp = ""
Else
strTemp = ""
Do While Not rsClass.EOF
tmpDepth = rsClass(3)
If rsClass(4) > 0 Then
arrShowLine(tmpDepth) = True
Else
arrShowLine(tmpDepth) = False
End If
strTemp = strTemp & ""
rsClass.MoveNext
Loop
End If
rsClass.Close
Set rsClass = Nothing
GetClass_Option = strTemp
End Function
Function GetOrderTyOption(OrderType)
Dim strOrderType
strOrderType = strOrderType & ""
strOrderType = strOrderType & ""
strOrderType = strOrderType & ""
strOrderType = strOrderType & ""
strOrderType = strOrderType & ""
strOrderType = strOrderType & ""
GetOrderTyOption = strOrderType
End Function
Function GetOpenTyOption(OpenType)
Dim strOpenType
strOpenType = ""
GetOpenTyOption = strOpenType
End Function
Function GetPath(ParentID, ParentPath)
Dim strPath, i
If ParentID <= 0 Then
GetPath = "无（作为一级菜单）"
Exit Function
End If
Dim rsParent, sqlParent
sqlParent = "Select * from t_area where t_classid in (" & ParentPath & ") order by Depth"
Set rsParent = Conn.Execute(sqlParent)
Do While Not rsParent.EOF
For i = 1 To rsParent("Depth")
strPath = strPath & " "
Next
If rsParent("Depth") > 0 Then
strPath = strPath & "└ "
End If
strPath = strPath & rsParent("ClassName") & " "
rsParent.MoveNext
Loop
rsParent.Close
Set rsParent = Nothing
GetPath = strPath
End Function
'=================================================
'函数名：GetRootClass_Menu
'作 用：得到菜单无级下拉菜单效果的HTML代码
'参 数：无
'返回值：菜单无级下拉菜单效果的HTML代码
'=================================================
Function GetRootClass_Menu()
Dim Class_MenuTitle, strJS, strClassUrl, XmlText
ClassLink = XmlText("BaseText", "ClassLink", "|")
pNum = 1
pNum2 = 0
strJS = "stm_bm(['uueoehr',400,'','" & strInstallDir & "images/blank.gif',0,'','',0,0,0,0,0,1,0,0]);" & vbCrLf
strJS = strJS & "stm_bp('p0',[0,4,0,0,2,2,0,0,100,'',-2,'',-2,90,0,0,'#000000','transparent','',3,0,0,'#000000']);" & vbCrLf
strJS = strJS & "stm_ai('p0i0',[0,'" & ClassLink & "','','',-1,-1,0,'','_self','','','','',0,0,0,'','',0,0,0,0,1,'#f1f2ee',1,'#cccccc',1,'','',3,3,0,0,'#fffff7','#000000','#000000','#000000','9pt 宋体','9pt 宋体',0,0]);" & vbCrLf
If UseCreateHTML > 0 Then
strClassUrl = ChannelUrl & "/Index" & FileExt_Index
Else
strClassUrl = ChannelUrl & "/Index.asp"
End If
strJS = strJS & "stm_aix('p0i1','p0i0',[0,'" & ChannelName & "首页','','',-1,-1,0,'" & strClassUrl & "','_self','" & strClassUrl & "','','','',0,0,0,'','',0,0,0,0,1,'#f1f2ee',1,'#cccccc',1,'','',3,3,0,0,'#fffff7','#ff0000','#000000','#cc0000','9pt 宋体','9pt 宋体']);" & vbCrLf
strJS = strJS & "stm_aix('p0i2','p0i0',[0,'" & ClassLink & "','','',-1,-1,0,'','_self','','','','',0,0,0,'','',0,0,0,0,1,'#f1f2ee',1,'#cccccc',1,'','',3,3,0,0,'#fffff7','#000000','#000000','#000000','9pt 宋体','9pt 宋体',0,0]);" & vbCrLf
Dim sqlRoot, rsRoot, j
sqlRoot = "select * from t_area where ChannelID=" & ChannelID & " and Depth=0 and ShowOnTop=" & True & " order by RootID"
Set rsRoot = Conn.Execute(sqlRoot)
If Not (rsRoot.BOF And rsRoot.EOF) Then
j = 3
Do While Not rsRoot.EOF
If rsRoot("OpenType") = 0 Then
OpenTyClass = "_self"
Else
OpenTyClass = "_blank"
End If
If Trim(rsRoot("Tips")) <> "" Then
Class_MenuTitle = Replace(Replace(Replace(Replace(rsRoot("Tips"), "'", ""), """", ""), Chr(10), ""), Chr(13), "")
Else
Class_MenuTitle = ""
End If
If rsRoot("ClassType") = 1 Then
strClassUrl = GetClassUrl(rsRoot("ParentDir"), rsRoot("ClassDir"), rsRoot("ClassID"), rsRoot("ClassPurview"))
strJS = strJS & "stm_aix('p0i" & j & "','p0i0',[0,'" & rsRoot("ClassName") & "','','',-1,-1,0,'" & strClassUrl & "','" & OpenTyClass & "','" & strClassUrl & "','" & Class_MenuTitle & "','','',0,0,0,'','',0,0,0,0,1,'#f1f2ee',1,'#cccccc',1,'','',3,3,0,0,'#fffff7','#ff0000','#000000','#cc0000','9pt 宋体','9pt 宋体']);" & vbCrLf
If rsRoot("Child") > 0 Then
strJS = strJS & GetClassMenu(rsRoot("ClassID"), 0)
End If
Else
strJS = strJS & "stm_aix('p0i" & j & "','p0i0',[0,'" & rsRoot("ClassName") & "','','',-1,-1,0,'" & rsRoot("LinkUrl") & "','" & OpenTyClass & "','" & rsRoot("LinkUrl") & "','" & Class_MenuTitle & "','','',0,0,0,'','',0,0,0,0,1,'#f1f2ee',1,'#cccccc',1,'','',3,3,0,0,'#fffff7','#ff0000','#000000','#cc0000','9pt 宋体','9pt 宋体']);" & vbCrLf
End If
strJS = strJS & "stm_aix('p0i2','p0i0',[0,'" & ClassLink & "','','',-1,-1,0,'','_self','','','','',0,0,0,'','',0,0,0,0,1,'#f1f2ee',1,'#cccccc',1,'','',3,3,0,0,'#fffff7','#000000','#000000','#000000','9pt 宋体','9pt 宋体',0,0]);" & vbCrLf
j = j + 1
rsRoot.MoveNext
If MaxPerLine > 0 Then
If (j - 2) Mod MaxPerLine = 0 And Not rsRoot.EOF Then
strJS = strJS & "stm_em();" & vbCrLf
strJS = strJS & "stm_bm(['uueoehr',400,'','" & strInstallDir & "images/blank.gif',0,'','',0,0,0,0,0,1,0,0]);" & vbCrLf
strJS = strJS & "stm_bp('p0',[0,4,0,0,2,2,0,0,100,'',-2,'',-2,90,0,0,'#000000','transparent','',3,0,0,'#000000']);" & vbCrLf
strJS = strJS & "stm_ai('p0i0',[0,'" & ClassLink & "','','',-1,-1,0,'','_self','','','','',0,0,0,'','',0,0,0,0,1,'#f1f2ee',1,'#cccccc',1,'','',3,3,0,0,'#fffff7','#000000','#000000','#000000','9pt 宋体','9pt 宋体',0,0]);" & vbCrLf
End If
End If
Loop
End If
rsRoot.Close
Set rsRoot = Nothing
strJS = strJS & "stm_em();" & vbCrLf
GetRootClass_Menu = strJS
End Function
Function GetClassMenu(ID, ShowType)
Dim sqlClass, rsClass, Sub_MenuTitle, k, strJS, strClassUrl
strJS = ""
If pNum = 1 Then
strJS = strJS & "stm_bp('p" & pNum & "',[1,4,0,0,2,3,6,7,100,'progid:DXImageTransform.Microsoft.Fade(overlap=.5,enabled=0,Duration=0.43)',-2,'',-2,67,2,3,'#999999','#ffffff','',3,1,1,'#aca899']);" & vbCrLf
Else
If ShowType = 0 Then
strJS = strJS & "stm_bpx('p" & pNum & "','p" & pNum2 & "',[1,4,0,0,2,3,6]);" & vbCrLf
Else
strJS = strJS & "stm_bpx('p" & pNum & "','p" & pNum2 & "',[1,2,-2,-3,2,3,0]);" & vbCrLf
End If
End If
k = 0
sqlClass = "select * from t_area where ChannelID=" & ChannelID & " and ParentID=" & ID & " order by OrderID asc"
Set rsClass = Conn.Execute(sqlClass)
'set rsClass=conn.execute("GetChildClass_Article_Menu " & ID)
Do While Not rsClass.EOF
If rsClass("OpenType") = 0 Then
OpenTyClass = "_self"
Else
OpenTyClass = "_blank"
End If
If Trim(rsClass("Tips")) <> "" Then
Sub_MenuTitle = Replace(Replace(Replace(Replace(rsClass("Tips"), "'", ""), """", ""), Chr(10), ""), Chr(13), "")
Else
Sub_MenuTitle = ""
End If
If rsClass("ClassType") = 1 Then
strClassUrl = GetClassUrl(rsClass("ParentDir"), rsClass("ClassDir"), rsClass("t_classid"), rsClass("ClassPurview"))
If rsClass("Child") > 0 Then
strJS = strJS & "stm_aix('p" & pNum & "i" & k & "','p" & pNum2 & "i0',[0,'" & rsClass("ClassName") & "','','',-1,-1,0,'" & strClassUrl & "','" & OpenTyClass & "','" & strClassUrl & "','" & Sub_MenuTitle & "','','',6,0,0,'" & strInstallDir & "images/arrow_r.gif','" & strInstallDir & "images/arrow_w.gif',7,7,0,0,1,'#ffffff',0,'#cccccc',0,'','',3,3,0,0,'#fffff7','#000000','#000000','#ffffff','9pt 宋体']);" & vbCrLf
pNum = pNum + 1
pNum2 = pNum2 + 1
strJS = strJS & GetClassMenu(rsClass("t_classid"), 1)
Else
strJS = strJS & "stm_aix('p" & pNum & "i" & k & "','p" & pNum2 & "i0',[0,'" & rsClass("ClassName") & "','','',-1,-1,0,'" & strClassUrl & "','" & OpenTyClass & "','" & strClassUrl & "','" & Sub_MenuTitle & "','','',0,0,0,'','',0,0,0,0,1,'#f1f2ee',1,'#cccccc',0,'','',3,3,0,0,'#fffff7','#ff0000','#000000','#cc0000','9pt 宋体']);" & vbCrLf
End If
Else
strJS = strJS & "stm_aix('p" & pNum & "i" & k & "','p" & pNum2 & "i0',[0,'" & rsClass("ClassName") & "','','',-1,-1,0,'" & rsClass("LinkUrl") & "','" & OpenTyClass & "','" & rsClass("LinkUrl") & "','" & Sub_MenuTitle & "','','',0,0,0,'','',0,0,0,0,1,'#f1f2ee',1,'#cccccc',0,'','',3,3,0,0,'#fffff7','#ff0000','#000000','#cc0000','9pt 宋体']);" & vbCrLf
End If
k = k + 1
rsClass.MoveNext
Loop
rsClass.Close
Set rsClass = Nothing
strJS = strJS & "stm_ep();" & vbCrLf
GetClassMenu = strJS
End Function
Function GetJS_ClassMenu()
Dim sqlMenu, rsMenu, strMenu, PrevRootID, tmpDepth, i, strClassUrl
sqlMenu = "select * from t_area where ChannelID=" & ChannelID & " and Depth=1 order by RootID,OrderID"
Set rsMenu = Conn.Execute(sqlMenu)
If rsMenu.BOF And rsMenu.EOF Then
strMenu = "var menu0='没有任何子菜单';"
Else
strMenu = "var menu" & rsMenu("RootID") & "=" & Chr(34)
If rsMenu("ClassType") = 2 Then
strClassUrl = rsMenu("LinkUrl")
Else
strClassUrl = GetClassUrl(rsMenu("ParentDir"), rsMenu("ClassDir"), rsMenu("ClassID"), rsMenu("ClassPurview"))
End If
strMenu = strMenu & " " & rsMenu("ClassName") & " "
PrevRootID = rsMenu("RootID")
rsMenu.MoveNext
Do While Not rsMenu.EOF
If rsMenu("RootID") <> PrevRootID Then
strMenu = strMenu & Chr(34) & ";" & vbCrLf & "var menu" & rsMenu("RootID") & "=" & Chr(34)
End If
If rsMenu("ClassType") = 2 Then
strClassUrl = rsMenu("LinkUrl")
Else
strClassUrl = GetClassUrl(rsMenu("ParentDir"), rsMenu("ClassDir"), rsMenu("ClassID"), rsMenu("ClassPurview"))
End If
strMenu = strMenu & " " & rsMenu("ClassName") & " "
PrevRootID = rsMenu("RootID")
rsMenu.MoveNext
Loop
strMenu = strMenu & Chr(34) & ";" & vbCrLf
End If
rsMenu.Close
Set rsMenu = Nothing
GetJS_ClassMenu = strMenu
End Function
'=================================================
'函数名：GetRootClass
'作 用：显示一级菜单（无特殊效果）
'参 数：ShowType ----显示方式，1为普通下拉菜单式，2为纯文字式，无菜单效果
'=================================================
Function GetRootClass(ShowType)
Dim sqlRoot, rsRoot, strRoot, strClassUrl, iCount
ClassLink = XmlText("BaseText", "ClassLink", "|")
sqlRoot = "select * from t_area where ChannelID=" & ChannelID & " and ParentID=0 and ShowOnTop=" & True & " order by RootID"
Set rsRoot = Conn.Execute(sqlRoot)
If rsRoot.BOF And rsRoot.EOF Then
strRoot = "还没有任何菜单，请首先添加菜单。"
Else
If UseCreateHTML > 0 Then
strRoot = strRoot & "" & ClassLink & " " & ChannelName & "首页 " & ClassLink & ""
Else
strRoot = strRoot & "" & ClassLink & " " & ChannelName & "首页 " & ClassLink & ""
End If
Do While Not rsRoot.EOF
If rsRoot("ClassType") = 2 Then
strRoot = strRoot & " " & rsRoot("ClassName") & " " & ClassLink & ""
Else
strClassUrl = GetClassUrl(rsRoot("ParentDir"), rsRoot("ClassDir"), rsRoot("ClassID"), rsRoot("ClassPurview"))
strRoot = strRoot & " 0 And ShowType = 1 Then
strRoot = strRoot & " onMouseOver='ShowMenu(menu" & rsRoot("RootID") & ",100)'"
End If
strRoot = strRoot & "> " & rsRoot("ClassName") & " " & ClassLink & ""
End If
rsRoot.MoveNext
iCount = iCount + 1
If iCount Mod MaxPerLine = 0 And Not rsRoot.EOF Then
strRoot = strRoot & " " & ClassLink & ""
End If
Loop
End If
rsRoot.Close
Set rsRoot = Nothing
GetRootClass = strRoot
End Function
'=================================================
'函数名：GetClass_Tree
'作 用：得到所有菜单的树形目录效果的HTML代码
'参 数：无
'返回值：菜单的树形目录效果的HTML代码
'=================================================
Function GetClass_Tree()
Dim arrShowLine(20), Class_MenuTitle, i, strClassUrl
For i = 0 To UBound(arrShowLine)
arrShowLine(i) = False
Next
Dim rsClass, sqlClass, tmpDepth, strClassTree
sqlClass = "Select t_classid,ClassName,Depth,ParentID,NextID,LinkUrl,Child,Readme,ClassType,ParentDir,ClassDir,OpenType,ClassPurview from t_area where ChannelID=" & ChannelID & " order by RootID,OrderID"
Set rsClass = Conn.Execute(sqlClass)
If rsClass.BOF And rsClass.EOF Then
strClassTree = "没有任何菜单"
Else
strClassTree = ""
Do While Not rsClass.EOF
tmpDepth = rsClass(2)
If rsClass(4) > 0 Then
arrShowLine(tmpDepth) = True
Else
arrShowLine(tmpDepth) = False
End If
If Trim(rsClass(7)) <> "" Then
Class_MenuTitle = Replace(Replace(Replace(Replace(rsClass(7), "'", ""), """", ""), Chr(10), ""), Chr(13), "")
Else
Class_MenuTitle = ""
End If
If tmpDepth > 0 Then
For i = 1 To tmpDepth
If i = tmpDepth Then
If rsClass(4) > 0 Then
strClassTree = strClassTree & ""
Else
strClassTree = strClassTree & ""
End If
Else
If arrShowLine(i) = True Then
strClassTree = strClassTree & ""
Else
strClassTree = strClassTree & ""
End If
End If
Next
End If
If rsClass(6) > 0 Then
strClassTree = strClassTree & ""
Else
strClassTree = strClassTree & ""
End If
If rsClass("ClassType") = 2 Then
strClassUrl = rsClass("LinkUrl")
Else
strClassUrl = GetClassUrl(rsClass("ParentDir"), rsClass("ClassDir"), rsClass("t_classid"), rsClass("ClassPurview"))
End If
strClassTree = strClassTree & "" & rsClass(1) & ""
Else
strClassTree = strClassTree & ">" & rsClass(1)
End If
If rsClass(8) = 2 Then
strClassTree = strClassTree & "(外)"
End If
strClassTree = strClassTree & ""
If rsClass(6) > 0 Then
strClassTree = strClassTree & "（" & rsClass(6) & "）"
End If
strClassTree = strClassTree & " "
rsClass.MoveNext
Loop
End If
rsClass.Close
Set rsClass = Nothing
GetClass_Tree = strClassTree
End Function
'==================================================
'函数名：ShowSearchForm
'作 用：显示搜索表单
'参 数：ShowType ----显示方式。1为简洁模式，2为标准模式，3为高级模式
' CurrentID ----当前菜单ID
'返回值：搜索表单的HTML代码
'==================================================
Function ShowSearchForm(ShowType, CurrentID)
Dim strForm
If ShowType <> 1 And ShowType <> 2 And ShowType <> 3 Then
ShowType = 1
End If
strForm = "
"
strForm = strForm & "
"
ShowSearchForm = strForm
End Function
Sub DelInfo(arrClassID)
'On Error Resume Next
Dim sqlDel, rsDel
Dim InfoPath, FileExt
If IsValidID(arrClassID) = False Then Exit Sub
Select Case ModuleType
Case 1
sqlDel = "select ArticleID as InfoID,UpdateTime,Inputer,Deleted,PaginationType from Article"
Case 2
sqlDel = "select SoftID as InfoID,UpdateTime,Inputer,Deleted from Soft"
Case 3
sqlDel = "select PhotoID as InfoID,UpdateTime,Inputer,Deleted from Photo"
Case 5
sqlDel = "select ProductID as InfoID,UpdateTime,Inputer,Deleted from Product"
End Select
If InStr(arrClassID, ",") > 0 Then
sqlDel = sqlDel & " where t_classid in (" & arrClassID & ")"
Else
sqlDel = sqlDel & " where t_classid=" & arrClassID & ""
End If
Set rsDel = Server.CreateObject("ADODB.Recordset")
rsDel.Open sqlDel, Conn, 1, 3
Do While Not rsDel.EOF
InfoPath = HtmlDir & GetItemPath(StructureType, "", "", rsDel("UpdateTime")) & GetItemFileName(FileNameType, ChannelDir, rsDel("UpdateTime"), rsDel("InfoID"))
If fso.FileExists(Server.MapPath(InfoPath & FileExt_Item)) Then
fso.DeleteFile Server.MapPath(InfoPath & FileExt_Item)
End If
If ModuleType = 1 Then
If rsDel("PaginationType") > 0 Then
DelSerialFiles (Server.MapPath(InfoPath) & "_*" & FileExt_Item)
End If
End If
rsDel("Deleted") = True
rsDel.Update
rsDel.MoveNext
Loop
rsDel.Close
Set rsDel = Nothing
End Sub
Function GetClassUrl(sParentDir, sClassDir, iClassID, iClassPurview)
Dim strClassUrl
If (UseCreateHTML = 1 Or UseCreateHTML = 3) And iClassPurview < 2 Then
strClassUrl = ChannelUrl & GetListPath(StructureType, ListFileType, sParentDir, sClassDir) & GetListFileName(ListFileType, iClassID, 1, 1) & FileExt_List
Else
strClassUrl = ChannelUrl & "/ShowClass.asp?ClassID=" & iClassID
End If
GetClassUrl = strClassUrl
End Function
Function UpdateClassPurview(arrClassID)
Dim rsClass, sqlClass, rsPurview, iClassPurview
sqlClass = "select ClassPurview,ParentID,ParentPath,Child,arrChildID from t_area where t_classid in (" & arrClassID & ")"
Set rsClass = Server.CreateObject("Adodb.recordset")
rsClass.Open sqlClass, Conn, 1, 3
Do While Not rsClass.EOF
iClassPurview = rsClass("ClassPurview")
If iClassPurview < 2 And rsClass("ParentID") > 0 Then
Set rsPurview = Conn.Execute("select max(ClassPurview) from t_area where t_classid in (" & rsClass("ParentPath") & ")")
If rsPurview(0) > iClassPurview Then iClassPurview = rsPurview(0)
rsPurview.Close
Set rsPurview = Nothing
If iClassPurview > rsClass("ClassPurview") Then
rsClass("ClassPurview") = iClassPurview
rsClass.Update
End If
End If
If iClassPurview > 0 And rsClass("Child") > 0 Then
Conn.Execute ("update t_area set ClassPurview=" & iClassPurview & " where t_classid in (" & rsClass("arrChildID") & ") and ClassPurview<" & iClassPurview & "")
End If
rsClass.MoveNext
Loop
rsClass.Close
Set rsClass = Nothing
End Function
Function GetChannel_Option(iModuleType, iChannelID)
Dim rsGetAdmin, rsChannel
Dim strChannel
Set rsGetAdmin = Conn.Execute("select * from Admin where AdminName='" & AdminName & "'")
Set rsChannel = Conn.Execute("select ChannelID,ChannelName,ChannelDir from Channel where ModuleType=" & iModuleType & " and Disabled=" & False & " and ChannelType<=1 order by OrderID")
Do While Not rsChannel.EOF
If AdminPurview = 1 Or rsGetAdmin("AdminPurview_" & rsChannel("ChannelDir")) = 1 Then
If rsChannel(0) = iChannelID Then
strChannel = strChannel & ""
Else
strChannel = strChannel & ""
End If
End If
rsChannel.MoveNext
Loop
rsChannel.Close
Set rsChannel = Nothing
rsGetAdmin.Close
Set rsGetAdmin = Nothing
GetChannel_Option = strChannel
End Function
%>
"
Else
strClassTree = strClassTree & "
"
End If
Else
If arrShowLine(i) = True Then
strClassTree = strClassTree & "
"
Else
strClassTree = strClassTree & "
"
End If
End If
Next
End If
If rsClass(6) > 0 Then
strClassTree = strClassTree & "
"
Else
strClassTree = strClassTree & "
"
End If
If rsClass("ClassType") = 2 Then
strClassUrl = rsClass("LinkUrl")
Else
strClassUrl = GetClassUrl(rsClass("ParentDir"), rsClass("ClassDir"), rsClass("t_classid"), rsClass("ClassPurview"))
End If
strClassTree = strClassTree & "" & rsClass(1) & ""
Else
strClassTree = strClassTree & ">" & rsClass(1)
End If
If rsClass(8) = 2 Then
strClassTree = strClassTree & "(外)"
End If
strClassTree = strClassTree & ""
If rsClass(6) > 0 Then
strClassTree = strClassTree & "（" & rsClass(6) & "）"
End If
strClassTree = strClassTree & "
"
Else
Response.Write "
"
End If
If rsClass("Depth") = 0 Then
Response.Write ""
End If
Response.Write "