实现功能：
文件(夹)目录列表 提供了查阅目录下面的文件和文件夹
文件 写,创,删 提供了编辑,删除文件(文件夹)的操作
创建文件夹/文件 针对创建文件夹(文件)而设置.
上传文件 您可以模拟FTP上传,文件大小,类型不受限制.
有兴趣的自己体验，出现任何问题我均不承担任何后果，在此说，我没多少时间上网，经常也顾不过来，是看到最近经常有人问这方面的问题，就发上来，希望有所帮助。
upfso.asp //控制上传的文件
复制代码 代码如下:
!--#include file="upload.asp" -->
%'On Error Resume Next%>
STYLE type="text/css"> @import url("admin.css");/STYLE>
%
Server.ScriptTimeOut = 999
'up_filetype="RAR,ZIP,SWF,JPG,PNG,GIF,DOC,TXT,CHM,PDF,ACE,JPG,MP3,WMA,WMV,bmp"
IF Request.QueryString("yes")="upload" Then
path=Trim(request("path"))
'response.write(path"---")
'response.End
Dim FSO,FSOIsOK,F_FileName,mode
F_FileName=Trim(request("nn"))
mode =killint(Trim(request("mode")),0,0,2)
FSOIsOK=1
Set FSO=Server.CreateObject("Scripting.FileSystemObject")
If Err>0 Then
Err.Clear
FSOIsOK=0
End If
Dim D_Name,F_Name
If FSOIsOK=1 Then
If InStr(1,path,":\")=0 Then
path=Replace(Lcase(path),"\","/")
path = server.mappath(path)
path=Replace(path"/","//","/")
Else
path=Replace(Lcase(path),"/","\")
path=Replace(path"\","\\","\")
End If
if not fso.folderexists(path) Then
response.write "a href=""javascript:history.back()"">font color='#000080'>基本路径查找失败,返回/font>/a>"
response.End
End If
End If
Set FSO=Nothing
Dim FileUP
Set FileUP=New Upload_File
FileUP.GetDate(-1)
Dim F_FileType, F_File
Set F_File=FileUP.File("File")
If Len(F_FileName)2 Then F_FileName = F_File.FileName
If Len(F_FileName)2 Then
response.write("a href='javascript:history.go(-1);'>font color='#000080'>空文件,请返回/font>/a>")
response.End
End If
'F_FileType = Ucase(F_File.FileExt)
'IF F_File.FileSize > 90000 Then
' Response.Write("a href='javascript:history.go(-1);'>大小超过限制/a>")
'exit sub
IF IsvalidFileName(F_FileName) = False Then
Response.Write("a href='javascript:history.go(-1);'>font color='#000080'>名称有误/font>/a>")
Else
Dim FileIsExists
Set FSO=Server.CreateObject("Scripting.FileSystemObject")
FileIsExists=FSO.FileExists(pathF_FileName)
If FileIsExists=True And mode>1 Then
fso.deletefile(pathF_FileName)
Response.Write("font color='#000080'>文件已经存在,已经被删除/b>/a>;")
F_File.SaveToFile pathF_FileName
Response.Write("a href='upfso.asp?action=fsopath="path"'>b>font color='#000080'>点击这里继续上传:"pathF_FileName"/font>/b>/a>")
ElseIf FileIsExists=True And mode=1 Then
Response.Write("font color='#000080'>文件已经存在,您选择了不覆盖/font>/b>")
Else
F_File.SaveToFile pathF_FileName
Response.Write("a href='upfso.asp?action=fsopath="path"'>b>font color='#000080'>点击这里继续上传:"pathF_FileName"/font>/b>/a>")
End If
End IF
Set F_File=Nothing
Set FileUP=Nothing
Else
Dim path,nn,mmode
nn=Trim(request("nn"))
mmode=Trim(request("mode"))
path=Replace(request("path"),"//","/")
If path="" Then path="../newup/"
Response.Write("form enctype=""multipart/form-data"" method=""post"" action=""upfso.asp?yes=uploadpath="path"nn="nn"mode="mmode""" class=""admin_fso_up"" onsubmit=""CheckForm()"" name='form'>label>选择:input name=""File"" type=""File"" size=""20""/>/label>label> input type=""Submit"" name=""Submit"" class=""submit"" value="" 上传 "" />/label>/form>")
End IF
'效验名称
Function IsvalidFileName(File_Name)
IsvalidFileName = False
Dim re,reStr
Set re=new RegExp
re.IgnoreCase =True
re.Global=True
re.Pattern="[^_\.a-zA-Z\d]"
reStr=re.Replace(File_Name,"")
If File_Name = reStr Then IsvalidFileName=True
Set re=Nothing
End Function
%>
upload.asp // 上传类
复制代码 代码如下:
%
Dim oUpFileStream
Class Upload_File
Dim Form,File,Err
Private Sub Class_Initialize
Err=-1
End Sub
Private Sub Class_Terminate
'Clear Variables Objects
If Err 0 Then
oUpFileStream.Close
Form.RemoveAll
File.RemoveAll
Set Form=Nothing
Set File=Nothing
Set oUpFileStream =Nothing
End If
End Sub
Public Sub GetDate(RetSize)
'Define Variables
Dim RequestBinDate,sStart,bCrLf,sInfo,iInfoStart,iInfoEnd,tStream,iStart,oFileInfo
Dim iFileSize,sFilePath,sFileType,sFormvalue,sFileName
Dim iFindStart,iFindEnd
Dim iFormStart,iFormEnd,sFormName
If Request.TotalBytes 1 Then
Err=1
Exit Sub
End If
If RetSize > 0 Then
If Request.TotalBytes > RetSize Then
Err=2
Exit Sub
End If
End If
Set Form = Server.CreateObject("Scripting.Dictionary")
Form.CompareMode = 1
Set File = Server.CreateObject("Scripting.Dictionary")
File.CompareMode = 1
Set tStream = Server.CreateObject("Adodb.Stream")
Set oUpFileStream = Server.CreateObject("Adodb.Stream")
oUpFileStream.Type = 1
oUpFileStream.Mode = 3
oUpFileStream.Open
oUpFileStream.Write Request.BinaryRead(Request.TotalBytes)
oUpFileStream.Position=0
RequestBinDate = oUpFileStream.Read
iFormEnd = oUpFileStream.Size
bCrLf = chrB(13) chrB(10)
'Get Seperators
sStart = MidB(RequestBinDate,1, InStrB(1,RequestBinDate,bCrLf)-1)
iStart = LenB (sStart)
iFormStart = iStart+2
'Split Items
Do
iInfoEnd = InStrB(iFormStart,RequestBinDate,bCrLf bCrLf)+3
tStream.Type = 1
tStream.Mode = 3
tStream.Open
oUpFileStream.Position = iFormStart
oUpFileStream.CopyTo tStream,iInfoEnd-iFormStart
tStream.Position = 0
tStream.Type = 2
tStream.Charset = "UTF-8"
sInfo = tStream.ReadText
'Get form item name
iFormStart = InStrB(iInfoEnd,RequestBinDate,sStart)-1
iFindStart = InStr(22,sInfo,"name=""",1)+6
iFindEnd = InStr(iFindStart,sInfo,"""",1)
sFormName = Mid (sinfo,iFindStart,iFindEnd-iFindStart)
'If it's a file
If InStr (45,sInfo,"filename=""",1) > 0 Then
Set oFileInfo= new FileInfo
'Get File attributes
iFindStart = InStr(iFindEnd,sInfo,"filename=""",1)+10
iFindEnd = InStr(iFindStart,sInfo,"""",1)
sFileName = Mid (sinfo,iFindStart,iFindEnd-iFindStart)
oFileInfo.FileName = Mid (sFileName,InStrRev (sFileName, "\")+1)
oFileInfo.FilePath = Left (sFileName,InStrRev (sFileName, "\"))
oFileInfo.FileExt = Mid (sFileName,InStrRev (sFileName, ".")+1)
iFindStart = InStr(iFindEnd,sInfo,"Content-Type: ",1)+14
iFindEnd = InStr(iFindStart,sInfo,vbCr)
oFileInfo.FileType = Mid (sinfo,iFindStart,iFindEnd-iFindStart)
oFileInfo.FileStart = iInfoEnd
oFileInfo.FileSize = iFormStart -iInfoEnd -2
oFileInfo.FormName = sFormName
file.add sFormName,oFileInfo
Else
'If it's form item
tStream.Close
tStream.Type = 1
tStream.Mode = 3
tStream.Open
oUpFileStream.Position = iInfoEnd
oUpFileStream.CopyTo tStream,iFormStart-iInfoEnd-2
tStream.Position = 0
tStream.Type = 2
tStream.Charset = "UTF-8"
sFormvalue = tStream.ReadText
If Form.Exists (sFormName) Then
Form (sFormName) = Form (sFormName) ", " sFormValue
Else
Form.Add sFormName,sFormvalue
End If
End If
tStream.Close
iFormStart = iFormStart+iStart+2
'Exit at end of file
Loop Until (iFormStart+2) = iFormEnd
RequestBinDate=""
Set tStream = Nothing
End Sub
End Class
'Get File Info
Class FileInfo
Dim FormName,FileName,FilePath,FileSize,FileType,FileStart,FileExt
Private Sub Class_Initialize
FileName = ""
FilePath = ""
FileSize = 0
FileStart= 0
FormName = ""
FileType = ""
FileExt = ""
End Sub
'Save File Method
Public Function SaveToFile(FullPath)
Dim oFileStream,ErrorChar,i
On Error Resume Next
Set oFileStream=CreateObject("Adodb.Stream")
oFileStream.Type=1
oFileStream.Mode=3
oFileStream.Open
oUpFileStream.position=FileStart
oUpFileStream.copyto oFileStream,FileSize
oFileStream.SaveToFile FullPath,2
oFileStream.Close
Set oFileStream=Nothing
End Function
'Get File Content
Public Function GetDate
oUpFileStream.Position =FileStart
GetDate=oUpFileStream.Read(FileSize)
End Function
End Class
%>
核心函数
复制代码 代码如下:
Dim theInstalledObjects(17)
theInstalledObjects(0) = "MSWC.AdRotator"
theInstalledObjects(1) = "MSWC.BrowserType"
theInstalledObjects(2) = "MSWC.NextLink"
theInstalledObjects(3) = "MSWC.Tools"
theInstalledObjects(4) = "MSWC.Status"
theInstalledObjects(5) = "MSWC.Counters"
theInstalledObjects(6) = "IISSample.ContentRotator"
theInstalledObjects(7) = "IISSample.PageCounter"
theInstalledObjects(8) = "MSWC.PermissionChecker"
theInstalledObjects(9) = "Scripting.FileSystemObject"
theInstalledObjects(10) = "adodb.connection"
theInstalledObjects(11) = "SoftArtisans.FileUp"
theInstalledObjects(12) = "SoftArtisans.FileManager"
theInstalledObjects(13) = "JMail.SMTPMail"
theInstalledObjects(14) = "CDONTS.NewMail"
theInstalledObjects(15) = "Persits.MailSender"
theInstalledObjects(16) = "LyfUpload.UploadFile"
theInstalledObjects(17) = "Persits.Upload.1"
Dim fso
If IsObjInstalled(theInstalledObjects(9)) Then
Set fso =Server.CreateObject("Scripting.FileSystemObject")
End If
Function IsObjInstalled(strClassString)
On Error Resume Next
IsObjInstalled = False
Err = 0
Dim xTestObj
Set xTestObj = Server.CreateObject(strClassString)
If 0 = Err Then IsObjInstalled = True
Set xTestObj = Nothing
Err = 0
End Function
'检查组件版本
Public Function getver(Classstr)
On Error Resume Next
Dim xTestObj
Set xTestObj = Server.CreateObject(Classstr)
If Err Then
getver=""
else
getver=xTestObj.version
end if
Set xTestObj = Nothing
End Function
'效验名称
Function IsvalidFileName(File_Name)
IsvalidFileName = False
Dim re,reStr
Set re=new RegExp
re.IgnoreCase =True
re.Global=True
re.Pattern="[^_\.a-zA-Z\d]"
reStr=re.Replace(File_Name,"")
If File_Name = reStr Then IsvalidFileName=True
Set re=Nothing
End Function
'文件写入
Function writeto(xmlfloder,xmlfile,content,mode)
writeto=false
If Not IsObjInstalled(theInstalledObjects(9)) Then Exit Function
mode=killint(mode,0,0,2)
xmlfloder=server.mappath(xmlfloder)
Set fso =Server.CreateObject("Scripting.FileSystemObject")
if not fso.folderexists(xmlfloder) Then
fso.createfolder(xmlfloder)
End If
xmlfile=replace(xmlfloder"\","\\","\")xmlfile
' response.write(warn_red(xmlfile))
Dim fsoxml
If fso.fileexists(xmlfile) And mode=1 Then '存在不写
Exit Function
elseIf fso.fileexists(xmlfile) And mode=2 Then '重写
Set fsoxml=fso.opentextfile(xmlfile,2)
fsoxml.writeline(content)
fsoxml.close
writeto=true
ElseIf fso.fileexists(xmlfile) And mode=8 Then '追加
Set fsoxml=fso.opentextfile(xmlfile,8)
fsoxml.writeline(content)
fsoxml.close
writeto=true
ElseIf fso.fileexists(xmlfile) Then
Set fsoxml=fso.opentextfile(xmlfile,2)'重写
fsoxml.writeline(content)
fsoxml.close
writeto=true
Else
Set fsoxml=fso.createtextfile(xmlfile)'创建
fsoxml.writeline(content)
fsoxml.close
writeto=true
End If
End Function
'删除文件
Function delaspfile(x)
On Error Resume Next
delaspfile=False
If Not fileexitornot(x) Then
Exit Function
Else
fso.deletefile server.mappath(x)
delaspfile=True
End if
End Function
'文件存在
Function fileexitornot(file)
On Error Resume Next
Dim f_re_file
f_re_file=true
If not fso.fileexists(server.MapPath(file)) Then f_re_file=False
If err>0 Then f_re_file=False
fileexitornot=f_re_file
End Function
'错误抑制,打印错误
Function show_err(err)
On Error Resume Next
If err.Number > 0 Then
Response.Clear
Dim err_mess
err_mess="b>发生错误:/b>br/>错误 Number： " err.Number"br/>错误信息:"err.Description"br/>出错文件："err.Source"br/>出错行："err.Line"(不被支持)br/>" err
response.write(err_mess)
End if
End Function
'警告:
Function warn_red(mess)
warn_red="font color=red>b>跟踪:"mess"/b>/font>br/>"
End Function
'FSO文件目录
Function showallfile(path)
'On Error Resume Next
path=Replace(path,"//","/")
set fso = CreateObject("Scripting.FileSystemObject")
Dim uploadPath,uploadfolder,objSubFolders,allfiles,fileitem,objSubFolder,
sFileName
If InStr(1,path,":\")=0 Then
path=Replace(path,"\","/")
uploadPath = server.mappath(path)
Else
path=Replace(path,"/","\")
uploadPath=path
End If
response.write(warn_red(uploadPath))
if not fso.folderexists(uploadPath) Then
response.write warn_red("路径查找失败")
Exit Function
End If
Set uploadfolder = fso.GetFolder(uploadPath)
If uploadfolder.isrootfolder Then
response.write("b>根目录/b>br/>")
Else
response.write("b>font color=""#00008b"">父目录:/font>a href=""default.asp?action=fsothis=toppath="uploadfolder.parentfolder""">
"uploadfolder.parentfolder" /a>/b>br/>")
End If
response.write("b>目录大小:"int(uploadfolder.size/1024)" KB/b>br/>")
set objSubFolders=uploadfolder.Subfolders
Dim fso_mes
fso_mes="ol>"
for each objSubFolder in objSubFolders
fso_mes=fso_mes "li>b>a href=""default.asp?action=fsothis=toppath="path"/"objSubFolder.name""">font color=blue>" objSubFolder.name "/font>/a>/b>/li>"
next
set allfiles = uploadfolder.Files
for each fileitem in allfiles
fso_mes=fso_mes "li>a href=""default.asp?action=fsothis=filepath="path"/"fileitem.Name""">" fileitem.Name "/a>/li>"
Next
fso_mes=fso_mes"/ol>"
response.write(fso_mes)
response.write deltext(uploadPath,1)
End Function
'文件属性
Function filepro(name)
name=Replace(name,"//","/")
Dim whichfile
If InStr(1,name,":\")=0 Then
name=Replace(name,"\","/")
whichfile = server.mappath(name)
Else
name=Replace(name,"/","\")
whichfile=name
End If
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.fileexists(whichfile) Then
response.write(warn_red("文件不存在或者无访问权限"))
Exit Function
End If
Dim f2,s_mess
Set f2 = fso.GetFile(whichfile)
s_mess = "div class=""admin_post_form"">b>font color=""#00008b"">父目录:/font>a href=""default.asp?action=fsothis=toppath="f2.parentfolder""">"f2.parentfolder
"/a>/b>br/>"
s_mess = s_mess "文件名称：" f2.name "br>"
s_mess = s_mess "文件短路径名：" f2.shortPath "br>"
s_mess = s_mess "文件物理地址：" f2.Path "br>"
s_mess = s_mess "文件属性：" f2.Attributes "br>"
s_mess = s_mess "文件大小： " f2.size "br>"
s_mess = s_mess "文件类型： " f2.type "br>"
s_mess = s_mess "文件创建时间： " f2.DateCreated "br>"
s_mess = s_mess "最近访问时间: " f2.DateLastAccessed "br>"
s_mess = s_mess "最近修改时间: " f2.DateLastModified"br/>/div>"
response.write(s_mess)
If killint(Trim(request("type")),0,0,2)>0 Then
showtext(whichfile)
End If
response.write deltext(whichfile,0)
End Function
'
SUB showtext(files)
dim iStr,adosText,strasp
set adosText=Server.CreateObject("ADODB.Stream")
adosText.mode=3
adosText.type=2
adosText.charset="gb2312"
'adosText.charset="big5"
adosText.open
If InStr(1,files,":\")=0 Then
files=Replace(files,"\","/")
files = server.mappath(files)
Else
files=Replace(files,"/","\")
files=files
End If
adosText.loadFromFile (files)
strasp=adosText.ReadText()
adosText.close
set adosText=nothing%>
form method="post" class="admin_post_form" action="default.asp?action=fsothis=editmode=1">
textarea id="txt" name="txt" rows="15" cols="60">%=Server.HTMLEncode(strasp)%>/textarea>
label> input name="path" type="hidden" value="%=Trim(request("path"))%>"/>input type="submit" name="okedit" class="submit" value="确定编辑"> /label>
/form>
%End Sub
Function deltext(file,mode)
Dim deltext_mess
deltext_mess="div class=""deltext"">"
Select Case killint(mode,0,0,2)
Case 0:
deltext_mess=deltext_mess"文件操作:a href=""default.asp?action=fsothis=filepath="file""">属性/a>a onclick=""{if(confirm('警告,非文本请不要读取,否则文件无法读取了,你坚持点击确定么?劝你点击取消')){return true;} return false;}"" href=""default.asp?action=fsothis=filepath="file"type=1"">font color=red>b>编辑/b>/font>/a>a href=""default.asp?action=fsothis=movepath="file""">移动/a>a href=""default.asp?action=fsothis=copypath="file"mode=0"">复制/a>a href=""default.asp?action=fsothis=renamepath="file"mode=0"">重命名/a>a onclick=""{if(confirm('警告,删除操作不能恢复,小心使用!!!')){return true;} return false;}"" href=""default.asp?action=fsothis=delpath="file"mode=0"">font color=red>b>删除/b>/font>/a>"
Case 1:
deltext_mess=deltext_mess"文件夹操作:a href=""default.asp?action=fsothis=toppath="file""">列表/a>a href=""default.asp?action=fsothis=addpath="file"ff=1"">创建目录/a>a href=""default.asp?action=fsothis=addpath="file""">手建文件/a>a href=""default.asp?action=fsothis=uppath="file""">上传文件/a>a href=""default.asp?action=fsothis=movepath="file"mode=1"">移动/a>a href=""default.asp?action=fsothis=copypath="file"mode=1"">复制/a>a href=""default.asp?action=fsothis=renamepath="file"mode=1"">重命名/a>a onclick=""{if(confirm('警告,删除操作不能恢复,以上列表的文件全部被删除,你坚持点击确定么?劝你点击取消')){return true;} return false;}"" href=""default.asp?action=fsothis=delpath="file"mode=1"">font color=red>b>删除/b>/font>/a>"
End Select
deltext_mess=deltext_mess"/div>"
deltext=deltext_mess
End Function
