function.asp

BS在线文件管理系统的源码和说明

    Set fs = CreateObject("Scripting.FileSystemObject")
  if fs.FolderExists(folderspec) then
    Set f = fs.GetFolder(folderspec)
    f.delete true	'-----------可选参数是否强制删除 true
if Err.Description = "" then
    response.write("目录<font color=red>"& folderspec &"</font>删除成功！")
end if
  else
if Err.Description = "" then
    response.write("<font color=red>目录"& folderspec &"不存在！</font>")
end if
  end if
    Set f = nothing
    Set fs = nothing
if Err.Description<>"" then
	response.write("<font color=red>出现错误！操作未完成！</font>")
	Err.Clear
end if
End Function

'--------------------------------------------------移动目录到另一目录
Function MoveFolder(a_1,b_1)
On Error Resume Next
    a = Cstr(a_1)
    b = Cstr(b_1)
    Dim fs
    Set fs = CreateObject("Scripting.FileSystemObject")
  if fs.FolderExists(a) and fs.FolderExists(b) then
    fs.MoveFolder a,b		'-----是否覆盖原有目录，缺省为true
if Err.Description = "" then
   response.write("<font color=red>"& a &"</font>已成功移动到<font color=red>"& b &"</font>")
end if
  else
	if fs.FolderExists(a)=false then
if Err.Description = "" then
	    response.write("<font color=red>目录"& a &"不存在！</font>")
end if
	end if
	if fs.FolderExists(b)=false then
if Err.Description = "" then
	    response.write("<font color=red>目录"& b &"不存在！</font>")
end if
	end if
  end if
    Set fs = nothing
if Err.Description<>"" then
	response.write("<font color=red>出现错误！操作未完成！目标目录可能已存在！</font>")
	Err.Clear
end if
End Function

'-------------------------------------------------显示目录中所有文件
Function ShowFileList(folderspec_1)
On Error Resume Next
    folderspec = Cstr(folderspec_1)
    Dim fs, f, f1, fc, s
    Set fs = CreateObject("Scripting.FileSystemObject")
    if fs.FolderExists(folderspec)=false then
if Err.Description = "" then
	response.write("<font color=red>"& folderspec &"</font>不存在或没有访问权限！")
	exit function
end if
    end if
    Set f = fs.GetFolder(folderspec)
    Set fc = f.Files
	s = s &"<table width=377 height='100%' border=0 cellspacing=0 cellpadding=0>"
    For Each f1 in fc
	file = gFilepath&f1.name
	s = s & "<tr><td width=22>"
	s = s & "<img src=""images/"
	s = s & GetExtensionName(Cstr(file))
	s = s & ".gif"" border=0>"
	s = s & "</td><td width=235 height=15>"
If InStr(1, file, lcase(server.mappath("/"))) = 1 then
	s = s & "<a href=""http://" & Request.ServerVariables("server_name") & replace(replace(lcase(file), lcase(server.mappath("/")), ""),"\","/") &"""" & " title=""" & ShowFileInfo(file) &"""" &" target='_blank'>"
else
	s = s & "<a href=""javascript:;"" title=""不可通过点击浏览"" onclick=""javascript:alert('该文件不可通过点击浏览！')"">"
end if
	s = s & f1.name &"</a> <font size=1 color=#ccbbcc>"
	a = f1.size
	if a>1024 and a<1048576 then
		s = s & FormatNumber(a/1024)
		s = s &" KB</font>"
	else
		if a>1048576 then
		s = s & FormatNumber((a/1024)/1024)
		s = s &" MB</font>"
		else
		s = s & a
		s = s &" Bytes</font>"
		end if
	end if
        s = s & "</td></td><td width=30>"
	s = s & "<a href='javascript:;' onClick=""javascript: order('renamefile', '" & replace(replace(replace(file, "\", "\\"),"'","\'"),"""","\""") & "');"">"
	s = s & "改名</a></td><td width=30>"
	s = s & "<a href='javascript:;' onClick=""javascript: order('editfile', '"
	s = s & replace(replace(replace(file, "\", "\\"),"'","\'"),"""","\""")
	s = s & "');"">"
	s = s & "编辑</a></td><td width=30>"
	s = s & "<a href='javascript:;' onClick=""javascript: order('copyfile', '" & replace(replace(replace(file, "\", "\\"),"'","\'"),"""","\""") & "');"">"
	s = s & "复制</a></td><td width=30>"
	s = s & "<a href='javascript:;' onClick=""javascript: order('movefile', '" & replace(replace(replace(file, "\", "\\"),"'","\'"),"""","\""") & "');"">"
	s = s & "移动</a></td><td width=30>"
	s = s & "<a href='javascript:;' onclick=""javascript:if(confirm('确定删除文件『"
	s = s & replace(replace(replace(f1.name, "\", "\\"),"'","\'"),"""","\""")
	s = s & "』吗?')) order('delfile','"
	s = s & replace(replace(replace(replace(file, "\", "\\"),"'","\'"),"""","\"""), " ","@") & "','','');"">"
	s = s & "删除</a></td></tr>"
    Next
	s = s & "<tr><td>&nbsp;</td></tr>"
	s = s & "</table>"

if Err.Description<>"" then
	response.write("<font color=red>出现错误！操作未完成！</font>")
	Err.Clear
else
	response.write(s)
end if
End Function

'-----------------------------------------------显示目录中所有目录
Function ShowFolderList(folderspec_1)
On Error Resume Next
    folderspec = Cstr(folderspec_1)
    Dim fs, f, f1, fc, s
    Set fs = CreateObject("Scripting.FileSystemObject")
    if fs.FolderExists(folderspec)=false then
if Err.Description = "" then
	response.write("<font color=red>"& folderspec &"</font>不存在或没有访问权限！")
	exit function
end if
    end if
    Set f = fs.GetFolder(folderspec)
    Set fc = f.SubFolders
	s = s &"<table width=377 height='100%' border=0 cellspacing=0 cellpadding=0>"
    For Each f1 in fc
	folder = gFilePath & f1.name
	s = s & "<tr><td width=22>"
	s = s & "<img src=""images/folder.gif"" border=0>"
	s = s & "</td><td width=235 height=15>"
        s = s & "<a title=""" & showfolderinfo(folder) &""" href="""& Request.ServerVariables("Url") & "?dir=" & folder & "\"">"& f1.name &"</a> <font size=1 color=#ccbbcc>"
	a = f1.size
	if a>1024 and a<1048576 then
		s = s & FormatNumber(a/1024)
		s = s &" KB</font>"
	else
		if a>1048576 then
		s = s & FormatNumber((a/1024)/1024)
		s = s &" MB</font>"
		else
		s = s & a
		s = s &" Bytes</font>"
		end if
	end if
	s = s & "</td><td width=30>"
	s = s & "<a href='javascript:;' onClick=""javascript: order('renamefolder', '"
	s = s &  replace(replace(replace(folder, "\", "\\"),"'","\'"),"""","\""") & "');"">"
	s = s & "改名</a></td>"
	s = s & "<td width=30>"
	s = s & "<a href='javascript:;' onClick=""javascript: order('copyfolder', '"
	s = s &  replace(replace(replace(folder, "\", "\\"),"'","\'"),"""","\""") & "');"">"
	s = s & "复制</a></td>"
	s = s & "<td width=30>"
	s = s & "<a href='javascript:;' onClick=""javascript: order('movefolder', '"
	s = s &  replace(replace(replace(folder, "\", "\\"),"'","\'"),"""","\""") & "');"">"
	s = s & "移动</a></td>"
	s = s & "<td width=30>"
	s = s & "<a href='javascript:;' onclick=""javascript:if(confirm('确定删除目录『"
	s = s &  replace(replace(replace(f1.name, "\", "\\"),"'","\'"),"""","\""")
	s = s & "』吗?')) order('delfolder','"
	s = s & replace(replace(replace(replace(folder, "\", "\\"),"'","\'"),"""","\""")," ","@") & "','','');"">"
	s = s & "删除</a></td>"
        s = s & "</td></tr>"
    Next
	s = s & "<tr><td>&nbsp;</td></tr>"
	s = s & "</table>"

if Err.Description<>"" then
	response.write("<font color=red>出现错误！操作未完成！</font>")
	Err.Clear
else
	response.write(s)
end if
End Function

'-------------------------------------------------------重命名目录
Function RenameFolder(a_1,b_1)
On Error Resume Next
    a = Cstr(a_1)
    b = Cstr(b_1)
    Dim fs
    Set fs = CreateObject("Scripting.FileSystemObject")
    if fs.FolderExists(a_1)=false then
	if Err.Description = "" then
		response.write("目录<font color=red>"& a &"</font>不存在！")
		exit function
	end if
    else
	fs.MoveFolder a, b
	if Err.Description = "" then
		response.write("<font color=red>"& a &"</font>已更名为<font color=red>"& b &"</font>")
	end if
    end if
if Err.Description<>"" then
	response.write("<font color=red>出现错误！操作未完成！</font>")
	Err.Clear
end if
End Function

'-----------------返回包含路径最后一个组成部分的【基本名】，无扩展名
Function GetBaseName(path_1)
On Error Resume Next
    path = Cstr(path_1)
    Dim fs, f, fname
    Set fs = CreateObject("Scripting.FileSystemObject")
    fname=fs.GetBaseName(path)
    GetBaseName=fname
End Function

'-----------------返回包含路径最后一个组成部分的【扩展名】，无基本名
Function GetExtensionName(path_1)
On Error Resume Next
    path = Cstr(path_1)
    Dim fs, f, exname
    Set fs = CreateObject("Scripting.FileSystemObject")
    exname=lcase(fs.GetExtensionName(path))
'-------
Select case exname
case "txt": ex="txt"
case "chm": ex="chm"
case "hlp": ex="hlp"
case "doc": ex="doc"
case "pdf": ex="pdf"
case "pdg": ex="pdf"
case "gif": ex="gif"
case "jpg": ex="jpg"
case "png": ex="png"
case "bmp": ex="bmp"
case "asp": ex="asp"
case "jsp": ex="asp"
case "js" : ex="js"
case "m3u" : ex="mp3"
case "htm": ex="htm"
case "html": ex="htm"
case "shtml": ex="htm"
case "zip": ex="zip"
case "rar": ex="rar"
case "jar": ex="rar"
case "exe": ex="exe"
case "avi": ex="avi"
case "mpg": ex="avi"
case "mpeg": ex="avi"
case "rm" : ex="rm"
case "ram": ex="rm"
case "mid": ex="mid"
case "wav": ex="mid"
case "mp3": ex="mp3"
case "asf": ex="avi"
case "php": ex="asp"
case "php3": ex="asp"
case "aspx": ex="asp"
case "asa": ex="asp"
case "xsl": ex="xsl"
case "xml": ex="xml"
case "vbs": ex="vbs"
case "sys": ex="dll"
case "dll": ex="dll"
case "swf": ex="swf"
case "reg": ex="reg"
case "nfo": ex="nfo"
case "mdb": ex="mdb"
case "log": ex="txt"
case "inf": ex="inf"
case "ini": ex="inf"
case "db": ex="inf"
case "bat": ex="bat"
case "css": ex="css"
case "com": ex="exe"
case else ex="no"
End Select
'-------
    GetExtensionName = ex
End Function

'--------------将路径转化为类似f:\test\test\或者f:\test\test-----
Function GetPathWith(b_1)
 If InStr(1,b_1,"\\") Then
  b = GetPathWith(Replace(b_1,"\\","\"))
 Else
  b = b_1
 End If
 GetPathWith = Cstr(lcase(b))
End Function
'----------------------------------------------------------------
</script>
<%
'------------------------------程序变量设置----------------------
Dim version, copyright, name, mail
version = "1.0.2"
copyright = "&copy CopyRight 2003 Designed by <a href=""mailto:[e-mail]?subject=关于你的程序！"" title=""QQ:115254150"">Brightstar</a>"
name = "BS在线文件管理系统"
mail = "By <a href=""mailto:[e-mail]?subject=关于你的程序！"">Brightstar</a>"
%>