function.asp

BS在线文件管理系统,采用asp编程,实现了对文件的简单管理,并且有比较方便的各种功能的实现.-BS online document management system, using asp prog

End Function

'-------------------------------------------------显示目录中所有文件
Function ShowFileList(folderspec_1)
On Error Resume Next
    folderspec = Cstr(folderspec_1)
    If right(folderspec,1) <> "\" Then folderspec = folderspec & "\"
    Set fs = CreateObject("Scripting.FileSystemObject")
    if fs.FolderExists(folderspec)=false then
	response.write("目录" & redFont & folderspec &"</font>不存在或没有访问权限！")
	exit function
    end if
    Set f = fs.GetFolder(folderspec)
    Set fc = f.Files
	i = 0
	s = s & "<table width='377' height='100%' border=0 cellspacing=0 cellpadding=0>"
	s = s & "<form name='file'><tr><td width='275' colspan='2' height='15'>"
	s = s & "<b>=&gt;</b>文件列表 <b>=&gt;</b>操作 "
	s = s & "<a href=""javascript:order('copyfile','')"">复制</a> "
	s = s & "<a href=""javascript:order('movefile','')"">移动</a> "
	s = s & "<a href=""javascript:order('delfile','')"">删除</a> "
	s = s & "</td><td width='80' align='right'><a href='javascript:;'"
	s = s & " onclick='document.file.checkall.click();'>全部"
	s = s & "<input type='checkbox' name='checkall'"
	s = s & " onclick=""checkit('file');"" style='border:0px;height:15px'></a></td></tr>"
    For Each f1 in fc
	i = i + 1
	file = LCase(f1.path)
	fileI = replace(replace(replace(file, "\", "\\"),"'","\'"),"""","\""")
	s = s & "<tr><td width='22'><a href=""downfile.asp?filespec="&file
	s = s & """ onclick=""window.status='文件下载中，请稍候……';"" "
	s = s & "onblur=""window.status='';""><img src=""images/" & GetExtensionName(Cstr(file))
	s = s & ".gif"" border=0 title='点击下载该文件'></a></td><td width='275' height='15'>"
If InStr(file, lcase(server.mappath("/"))) > 0 then
	fci = replace(replace(lcase(file), lcase(server.mappath("/")), ""),"\","/")
	Urlfci = Server.URLEncode(Request.ServerVariables("server_name") & fci)
	s = s & "<a href=""http://" & Replace(Replace(Urlfci, "%2E","."),"%2F","/")
	s = s &""" title=""" & ShowFileInfo(file) &""" target='_blank'>"
else
	s = s & "<a href=""downfile.asp?filespec="&file&""" title='点击下载该文件'"
	s = s & " onclick=""window.status='文件下载中，请稍候……';"" "
	s = s & "onblur=""window.status='';"">"
end if
	s = s & f1.name &"</a>"
        s = s & "</td></td><td width='80' align='right'><a href='javascript:;' onClick="""
	s = s & "javascript: order('renamefile', '" & fileI & "');"">改名</a> "
	s = s & "<a href='javascript:;' onClick=""javascript: order('editfile', '" & fileI
	s = s & "');"">编辑</a><input type='checkbox' name='a' class='input' "
	s = s & "style='border:0px;height:15px' value='" & fileI & "'></td></tr>"
    Next
	s = s & "<tr><td colspan=3><input type='hidden' name='b' value='"&i&"'></td></tr>"
	s = s & "</form></table>"
    Set fs = nothing
    Response.write(s)
End Function

'-----------------------------------------------显示目录中所有目录
Function ShowFolderList(folderspec_1)
On Error Resume Next
    folderspec = Cstr(folderspec_1)
    If right(folderspec,1) <> "\" Then folderspec = folderspec & "\"
    Set fs = CreateObject("Scripting.FileSystemObject")
    if fs.FolderExists(folderspec)=false then
	response.write("目录" & redFont & folderspec &"</font>不存在或没有访问权限！")
	exit function
    end if
    Set f = fs.GetFolder(folderspec)
    Set fc = f.SubFolders
	i = 0
	s = s & "<table width=377 height='100%' border=0 cellspacing=0 cellpadding=0>"
	s = s & "<form name='folder'><tr><td width=327 colspan=2 height=15>"
	s = s & "<b>=&gt;</b>目录列表 <b>=&gt;</b>操作 "
	s = s & "<a href=""javascript:order('copyfolder','')"">复制</a> "
	s = s & "<a href=""javascript:order('movefolder','')"">移动</a> "
	s = s & "<a href=""javascript:order('delfolder','')"">删除</a> "
	s = s & "</td><td width=50><a href='javascript:;'"
	s = s & " onclick='document.folder.checkall.click();'>全部"
	s = s & "<input type='checkbox' name='checkall'"
	s = s & " onclick=""checkit('folder');"" style='border:0px;height:15px'></a></td></tr>"
    For Each f1 in fc
	i = i + 1
	folder = LCase(f1.path)
	folderI = replace(replace(replace(folder, "\", "\\"),"'","\'"),"""","\""")
	s = s & "<tr><td width=22><img src=""images/folder.gif"" border=0>"
	s = s & "</td><td width=305 height=15><a title=""" & showfolderinfo(folder) &""" href="""
	s = s & Request.ServerVariables("Url") & "?dir=" & folder & "\"">"& f1.name &"</a>"
	s = s & "</td><td width=50>"
	s = s & "<a href='javascript:;' onClick=""javascript: order('renamefolder', '"
	s = s & folderI & "');"">改名</a><input type='checkbox' name='a' class='input'"
	s = s & " style='border:0px;height:15px' value='" & folderI & "'></td></tr>"
    Next
	s = s & "<tr><td colspan=3><input type='hidden' name='b' value='"&i&"'></td></tr>"
	s = s & "</form></table>"
    Set fs = nothing
    Response.write(s)
End Function

'-------------------------------------------------------重命名目录
Function RenameFolder(folder1,folder2)
On Error Resume Next
    folder1 = Cstr(folder1)
    folder2 = Cstr(folder2)
    If right(folder1,1) = "\" Then folder1 = Left(folder1, Len(folder1)-1)
    If right(folder2,1) = "\" Then folder2 = Left(folder2, Len(folder2)-1)
    Set fs = CreateObject("Scripting.FileSystemObject")
    if fs.FolderExists(folder2)=true then
	response.write("目录" & redFont & folder1 &"</font>已经存在！")
	exit function
    end if
    if fs.FolderExists(folder1)=false then
	response.write("目录" & redFont & folder1 &"</font>不存在！")
	exit function
    else
	fs.MoveFolder folder1, folder2
	if fs.FolderExists(folder2)=true then
		s = "目录" & redFont & folder1 &"</font>已更名为" & redFont & folder2 &"</font>"
		response.write(s)
	else
		response.write( redFont & "出现错误！操作未完成！</font>")
		Err.Clear
	end if
    end if
    Set fs = nothing
End Function

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

'-----------------返回包含路径的扩展名，以便确定图标图片名字
Function GetExtensionName(path_1)
On Error Resume Next
    path = Cstr(path_1)
    Set fs = CreateObject("Scripting.FileSystemObject")
    exname=lcase(fs.GetExtensionName(path))
    Set fs = nothing
'-------
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
'--------------返回包含路径最后一个组成部分的【扩展名】，无基本名
Function GetExten(path_1)
On Error Resume Next
    path = Cstr(trim(path_1))
    Set fs = CreateObject("Scripting.FileSystemObject")
    exten=lcase(fs.GetExtensionName(path))
    Set fs = nothing
GetExten = exten
End Function
'----------------检查是否是限制的文件类型-------------------------
Function CheckExten(exten)
  If session("exten") <> "" and not session("admin") Then
    myExten = Split(LCase(CStr(session("exten"))), ".")
    For each subExten in myExten
	If subExten = exten Then
	    CheckExten = false
	    Exit Function
	End If
    Next
    CheckExten = true
  Else
    CheckExten = true
  End If
End Function
'--------------将路径转化为类似f:\test\test------------------------
Function GetPathWith(pathStr)
 If InStr(pathStr,"||") > 0 or InStr(pathStr,"\\") > 0 Then
  pathStr = GetPathWith(Replace(Replace(pathStr,"||","|"),"\\","\"))
 End If
 Set objFs = CreateObject("Scripting.FileSystemObject")
 specOnePath = Split(pathStr,"|")
 For each itPath in specOnePath
 If CheckCorrectPath(itPath) Then
  pathStr = Trim(CStr(LCase(objFs.GetAbsolutePathName(pathStr))))
 Else
  pathStr = ""
  Exit For
 End If
 Next
 Set objFs = Nothing
 GetPathWith = pathStr
End Function
'---------------检测a是否为允许文件类型
Sub checka()
exten = GetExten(a)
If Not CheckExten(exten) Then
	response.write("<meta http-equiv='Content-Type' content='text/html; charset=gb2312'>")
	response.write("<script language=""javascript"">")
	response.write("alert(""你没有对此文件类型的访问权限！"");")
	response.write("self.close();")
	response.write("</script>")
	response.end
End If
End Sub
'---------------检测b是否为允许文件类型
Sub checkb()
exten = GetExten(b)
If Not CheckExten(exten) Then
	response.write("<meta http-equiv='Content-Type' content='text/html; charset=gb2312'>")
	response.write("<script language=""javascript"">")
	response.write("alert(""你没有对此文件类型的访问权限！"");")
	response.write("self.close();")
	response.write("</script>")
	response.end
End If
End Sub
'-----------------------------------文件下载---------------------------
Function downLoadFile(FileSpec)
on error resume next
    Const ForReading=1
    Const TristateTrue=-1 
    Const FILE_TRANSFER_SIZE=1024	'16384
    Dim objFileSystem, objFile, objStream
    Dim char
    Dim sent
    Set objFileSystem = CreateObject("Scripting.FileSystemObject")
    If objFileSystem.FileExists(fileSpec)=false Then
	response.write("<Script>alert(""请求文件不存在！"");history.back();</script>")
	Exit Function
    End If
    FileName = objFileSystem.GetFileName(FileSpec)
    send=0
    TransferFile = True
    Set objFileSystem = Server.CreateObject("Scripting.FileSystemObject")
    Set objFile = objFileSystem.GetFile(FileSpec)
    Set objStream = objFile.OpenAsTextStream(ForReading, TristateTrue)
    Response.AddHeader "content-type", "application/octet-stream"
    Response.AddHeader "Content-Disposition","attachment;filename=" & filename 
    Response.AddHeader "content-length", objFile.Size
    Do While Not objStream.AtEndOfStream
	char = objStream.Read(1)
	Response.BinaryWrite(char)
	sent = sent + 1
	If (sent MOD FILE_TRANSFER_SIZE) = 0 Then
	    Response.Flush
	    If Not Response.IsClientConnected Then
		TransferFile = False
		Exit Do
	    End If
	End If
    Loop
    Response.Flush
    If Not Response.IsClientConnected Then TransferFile = False
    objStream.Close
    Set objStream = Nothing
    Set objFileSystem = Nothing
End Function
'*******************************程序变量设置**************************
 Dim version, copyright, name, mail, sysdir, rootdir, redFont
 version = "2.0 简体中文版"
 name = "BS在线文件管理系统"
 mail = "By <a href='mailto:[e-mail]?subject=关于"&name&version&"'>Brightstar</a>"
 copyright = "&copy CopyRight 2003 Designed " & mail
 sysdir = Replace(Server.MapPath("index.asp"),"index.asp","")	'本系统所在目录
 rootdir = Request.ServerVariables("APPL_PHYSICAL_PATH")		'网站根目录
 redFont = "<font color=red>"
%>