cls_adminfile.asp

网络上经典的图片程序

<%
Dim NewCloud
Set NewCloud = New Cls_AdminUploadFile

Class Cls_AdminUploadFile
	Private fromPath, modules
	Private ChannelDir, fullPath, FilePath, UploadDir, ThisDir
	Private Action, AdminFlag,rsChannel


	Public Sub ShowUploadFile()
		ChannelID = Newasp.ChkNumeric(Request("ChannelID"))
		AdminFlag = "AdminUpload" & ChannelID
		Action = LCase(Request("action"))
		If Not ChkAdmin(AdminFlag) Then
			Server.Transfer ("showerr.asp")
			Response.End
		End If
		Admin_header
		If ChannelID > 0 Then
			Set rsChannel = Newasp.Execute("SELECT ChannelDir,modules FROM NC_Channel WHERE ChannelType < 2 And ChannelID = " & ChannelID)
			If Not (rsChannel.BOF And rsChannel.EOF) Then
				ChannelDir = Trim(Newasp.InstallDir) & Trim(rsChannel("ChannelDir"))
				modules = rsChannel("modules")
			Else
				ChannelDir = Trim(Newasp.InstallDir) & "adfile/"
				modules = 0
			End If
			rsChannel.Close: Set rsChannel = Nothing
		Else
			ChannelID = 0
			modules = 0
			ChannelDir = Trim(Newasp.InstallDir) & "adfile/"
		End If
		If Trim(Request("UploadDir")) <> "" Then
			UploadDir = Trim(Request("UploadDir")) & "/"
		End If
		If Trim(Request("ThisDir")) <> "" Then
			ThisDir = Trim(Request("ThisDir")) & "/"
		End If
		ThisDir = Replace(ThisDir, "\", "/")
		If ChannelID = 0 Then
			fromPath = Replace("adfile/" & UploadDir, "\", "/")
		Else
			fromPath = Replace(UploadDir, "\", "/")
		End If
		FilePath = Replace(ChannelDir & UploadDir, "\", "/")
		fullPath = Server.MapPath(FilePath)

		Select Case Trim(Action)
		Case "clear"
			Call ClearUploadFile
		Case "delete"
			Call DelUselessFile
		Case "del"
			Call DelFile
		Case "delalldirfile"
			Call DelAllDirFile
		Case "delthisallfile"
			Call DelThisAllFile
		Case "delemptyfolder"
			Call DelEmptyFolder
		Case Else
			Call ShowUploadMain
		End Select
		If FoundErr = True Then
			ReturnError (ErrMsg)
		End If
		Admin_footer
	End Sub
	'=================================================
	'过程名：ShowSelectFile
	'作  用：显示选择文件
	'=================================================
	Public Sub ShowSelectFile()
		Admin_header
		Response.Write "<base target=""_self"">" & vbNewLine
		ChannelID = Newasp.ChkNumeric(Request("ChannelID"))
		AdminFlag = "AdminSelect" & ChannelID
		If Not ChkAdmin(AdminFlag) Then
			Server.Transfer ("showerr.asp")
			Response.End
		End If
		
		If ChannelID > 0 Then
			ChannelID = CInt(Request("ChannelID"))
			Set rsChannel = Newasp.Execute("SELECT ChannelDir FROM NC_Channel WHERE ChannelType < 2 And ChannelID = " & ChannelID)
			If Not (rsChannel.BOF And rsChannel.EOF) Then
				ChannelDir = Trim(Newasp.InstallDir) & Trim(rsChannel("ChannelDir"))
			Else
				ChannelDir = Trim(Newasp.InstallDir) & "adfile/"
			End If
			rsChannel.Close: Set rsChannel = Nothing
		Else
			ChannelID = 0
			ChannelDir = Trim(Newasp.InstallDir) & "adfile/"
		End If
		If Trim(Request("UploadDir")) <> "" Then
			UploadDir = Trim(Request("UploadDir")) & "/"
		End If
		'If Trim(Request("ThisDir")) <> "" Then
			'ThisDir = Trim(Request("ThisDir")) & "/"
		'End If
		'ThisDir = Replace(ThisDir, "\", "/")
		If ChannelID = 0 Then
			fromPath = Replace("adfile/" & UploadDir, "\", "/")
		Else
			fromPath = Replace(UploadDir, "\", "/")
		End If
		FilePath = Replace(ChannelDir & UploadDir, "\", "/")
		fullPath = Server.MapPath(FilePath)
		Call ShowSelectMain
		If FoundErr = True Then
			ReturnError (ErrMsg)
		End If
		Admin_footer
	End Sub
	'=================================================
	'过程名：ShowSelectMain
	'作  用：显示选择文件主页面
	'=================================================
	Private Sub ShowSelectMain()
		Dim maxperpage, CurrentPage, TotalNumber, Pcount
		Dim fso, FileCount, TotleSize, totalPut
		maxperpage = 20 '###每页显示数
		
		If IsNumeric(Request("page")) And Trim(Request("page")) <> "" Then
			CurrentPage = CLng(Request("page"))
		Else
			CurrentPage = 1
		End If
		If CLng(CurrentPage) = 0 Then CurrentPage = 1
		On Error Resume Next
		If Not IsObjInstalled(Newasp.FSO_ScriptName) Then
			Response.Write "<b><font color=red>你的服务器不支持 fso(Scripting.FileSystemObject)! 不能使用本功能</font></b>"
		End If
		
		Response.Write "<table border=0 align=center cellpadding=3 cellspacing=1 class=tableborder>"
		Response.Write "<tr>"
		Response.Write "        <th colspan=""2"">文件目录</th>"
		Response.Write "</tr>"
		Response.Write "<tr>"
		Response.Write "        <td class=tablerow1 colspan=""2"">"
		Call ShowChildFolder
		Response.Write "</td>"
		Response.Write "</tr>"
		Response.Write "<tr>"
		Response.Write "        <td width=""50%"" class=tablerow2>当前目录：" & FilePath & "</td>"
		Response.Write "        <td width=""50%"" align=center class=tablerow2>"
		If Trim(Request("ThisDir")) <> "" Then
			Response.Write "<a href=""admin_selFile.asp?ChannelID=" & ChannelID & "&UploadDir=" & Left(Request("UploadDir"),Len(Request("UploadDir"))-Len(Mid(Request("UploadDir"), InStrRev(Request("UploadDir"), "/")))) & "&ThisDir=" & Request("ThisDir") & """>↑返回上一层目录</a>"
		End If
		Response.Write "</td>"
		Response.Write "</tr>"
		Response.Write "</table><br>" & vbNewLine

		Set fso = CreateObject(Newasp.FSO_ScriptName)
		If fso.FolderExists(fullPath) Then
			Dim fsoFile, fsoFileSize
			Dim DirFiles, DirFolder
			Set fsoFile = fso.GetFolder(fullPath)
			'fsoFileSize = fsoFile.size '空间大小统计
			Dim c
			FileCount = fsoFile.Files.Count
			TotleSize = GetFileSize(fsoFile.Size)
			totalPut = fsoFile.Files.Count
			If CurrentPage < 1 Then
				CurrentPage = 1
			End If
			If (CurrentPage - 1) * maxperpage > totalPut Then
				If (totalPut Mod maxperpage) = 0 Then
					CurrentPage = totalPut \ maxperpage
				Else
					CurrentPage = totalPut \ maxperpage + 1
				End If
			End If
			FileCount = 0
			c = 0
			Response.Write "<table border=0 align=center cellpadding=3 cellspacing=1 class=tableborder>" & vbNewLine
			Response.Write "<tr><td colspan=4 class=tablerow1>" & vbNewLine
			Response.Write showpage(CurrentPage, totalPut, maxperpage, TotleSize)
			Response.Write "</td></tr>" & vbNewLine
			Response.Write "<tr>" & vbNewLine
			For Each DirFiles In fsoFile.Files
				c = c + 1
				If c > maxperpage * (CurrentPage - 1) Then
					Response.Write "<td class=tablerow2>"
					Response.Write "<div align=center><a href='#' onClick=""window.returnValue='" & fromPath & DirFiles.Name & "|" & CLng(DirFiles.Size \ 1024) & "';window.close();""><img src='" & GetFilePic(FilePath & DirFiles.Name) & "' width=140 height=100 border=0 alt='点此图片将返回，点下面的文件名将查看原始文件！'></a></div>"
					Response.Write "文件名：<a href='" & FilePath & DirFiles.Name & "'target=_blank>" & DirFiles.Name & "</a><br>"
					Response.Write "文件大小：" & GetFileSize(DirFiles.Size) & "<br>"
					Response.Write "文件类型：" & DirFiles.Type & "<br>"
					Response.Write "修改时间：" & DirFiles.DateLastModified
					FileCount = FileCount + 1
					Response.Write "</td>" & vbNewLine
					If (FileCount Mod 4) = 0 And FileCount < maxperpage And c < totalPut Then
						Response.Write "</tr>" & vbNewLine & "<tr>" & vbNewLine
					End If
				End If
				If FileCount >= maxperpage Then Exit For
			Next
			Response.Write "</tr>" & vbNewLine
			Response.Write "<tr><td colspan=4 class=tablerow1>" & vbNewLine
			Response.Write showpage(CurrentPage, totalPut, maxperpage, TotleSize)
			Response.Write "</td></tr>" & vbNewLine
			Response.Write "</table>"
		Else
			Response.Write "此目录没有任何文件！"
		End If
		Set fsoFile = Nothing: Set fso = Nothing
	End Sub
	'=================================================
	'过程名：ShowChildFolder
	'作  用：显示子目录菜单
	'=================================================
	Private Sub ShowChildFolder()
		Dim fso, fsoFile, DirFolder
		Dim strFolderPath
		On Error Resume Next
		strFolderPath = ChannelDir & Request("UploadDir")
		strFolderPath = Server.MapPath(strFolderPath)
		Set fso = CreateObject(Newasp.FSO_ScriptName)
		If fso.FolderExists(strFolderPath) Then
			Set fsoFile = fso.GetFolder(strFolderPath)
			For Each DirFolder In fsoFile.SubFolders
				Response.Write "<a href=""?ChannelID=" & ChannelID & "&UploadDir=" & Request("UploadDir") & "/" & DirFolder.Name& "&ThisDir=" & DirFolder.Name & """><img src=""images/pic/mediafolder.gif"" width=20 height=20 border=0 alt=""修改时间：" & DirFolder.DateLastModified & """ align=absMiddle> "
				If Replace(ThisDir, "/", "") = DirFolder.Name Then
					Response.Write "<font color=red>" & DirFolder.Name & "</font>"
				Else
					Response.Write DirFolder.Name
				End If
				Response.Write "</a> &nbsp;&nbsp;" & vbNewLine
			Next
		Else
			Response.Write "没有找到文件夹！"
		End If
		Set fsoFile = Nothing: Set fso = Nothing
	End Sub

	'=================================================
	'函数名：showpage
	'作  用：分页
	'=================================================
	Private Function showpage(ByVal CurrentPage, ByVal TotalNumber, ByVal maxperpage, ByVal TotleSize)
		Dim n
		Dim strTemp
		
		If (TotalNumber Mod maxperpage) = 0 Then
			n = TotalNumber \ maxperpage
		Else
			n = TotalNumber \ maxperpage + 1
		End If
		strTemp = "<table align='center'><form method='Post' action='?ChannelID=" & ChannelID & "&UploadDir=" & Request("UploadDir") & "&ThisDir=" & Request("ThisDir") & "'><tr><td>" & vbNewLine
		strTemp = strTemp & "共 <b>" & TotalNumber & "</b> 个文件，占用 <b>" & TotleSize & "</b>&nbsp;&nbsp;"
		'sfilename = JoinChar(sfilename)
		If CurrentPage < 2 Then
			strTemp = strTemp & "首页 上一页&nbsp;"
		Else
			strTemp = strTemp & "<a href='?page=1&ChannelID=" & ChannelID & "&UploadDir=" & Request("UploadDir") & "&ThisDir=" & Request("ThisDir") & "'>首页</a>&nbsp;"
			strTemp = strTemp & "<a href='?page=" & (CurrentPage - 1) & "&ChannelID=" & ChannelID & "&UploadDir=" & Request("UploadDir") & "&ThisDir=" & Request("ThisDir") & "'>上一页</a>&nbsp;"
		End If

		If n - CurrentPage < 1 Then
			strTemp = strTemp & "下一页 尾页"
		Else
			strTemp = strTemp & "<a href='?page=" & (CurrentPage + 1) & "&ChannelID=" & ChannelID & "&UploadDir=" & Request("UploadDir") & "&ThisDir=" & Request("ThisDir") & "'>下一页</a>&nbsp;"
			strTemp = strTemp & "<a href='?page=" & n & "&ChannelID=" & ChannelID & "&UploadDir=" & Request("UploadDir") & "&ThisDir=" & Request("ThisDir") & "'>尾页</a>"
		End If
		strTemp = strTemp & "&nbsp;页次：<strong><font color=red>" & CurrentPage & "</font>/" & n & "</strong>页 "
		strTemp = strTemp & "&nbsp;转到："
		strTemp = strTemp & "<input name=page size=3 value='" & CurrentPage & "'> <input type=submit name=Submit value='转到' class=Button>"
		strTemp = strTemp & "</select>"
		strTemp = strTemp & "</td>"
		strTemp = strTemp & "<td>&nbsp;【<a href='#' onClick=""window.close();"">关闭本窗口</a>】&nbsp;</td>"
		strTemp = strTemp & "</tr></form></table>"
		showpage = strTemp
	End Function
	'=================================================
	'函数名：GetFilePic
	'作  用：获取文件图片
	'=================================================
	Private Function GetFilePic(sName)
		Dim FileName, Icon
		FileName = LCase(GetExtensionName(sName))
		Select Case FileName
			Case "gif", "jpg", "bmp", "png"
				Icon = sName
			Case "exe"
				Icon = "images/pic/file_exe.gif"
			Case "rar"
				Icon = "images/pic/file_rar.gif"
			Case "zip"
				Icon = "images/pic/file_zip.gif"
			Case "swf"
				Icon = "images/pic/file_flash.gif"
			Case "rm", "wma"
				Icon = "images/pic/file_rm.gif"
			Case "mid"
				Icon = "images/pic/file_media.gif"
			Case Else
				Icon = "images/pic/file_other.gif"
		End Select
		GetFilePic = Icon
	End Function
	'=================================================
	'函数名：GetExtensionName
	'作  用：获取文件扩展名
	'=================================================
	Private Function GetExtensionName(ByVal sName)
		Dim FileName
		FileName = Split(sName, ".")
		GetExtensionName = FileName(UBound(FileName))
	End Function
	'=================================================
	'函数名：GetFileSize
	'作  用：格式化文件的大小
	'=================================================
	Private Function GetFileSize(ByVal n)
		Dim FileSize
		FileSize = n / 1024
		FileSize = FormatNumber(FileSize, 2)
		If FileSize < 1024 And FileSize > 1 Then
			GetFileSize = "<font color=red>" & FileSize & "</font>&nbsp;KB"
		ElseIf FileSize > 1024 Then
			GetFileSize = "<font color=red>" & FormatNumber(FileSize / 1024, 2) & "</font>&nbsp;MB"
		Else
			GetFileSize = "<font color=red>" & n & "</font>&nbsp;Bytes"
		End If
	End Function
	'=================================================
	'过程名：DelFile
	'作  用：删除文件
	'=================================================