谢绝转载

1：请尊重我的劳动成果，贴出以下代码只帮助个人欣赏或者学习，请直接copy不要用于商业用途。
2： 这是我从我写的某系统里面剔出的程序，当时水平差（现在也是），程序绝非产品级的代码，但绝非无价值的。

实现功能：
文件(夹)目录列表 提供了查阅目录下面的文件和文件夹
文件 写,创,删 提供了编辑,删除文件(文件夹)的操作
创建文件夹/文件 针对创建文件夹(文件)而设置.
上传文件 您可以模拟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(path&F_FileName) If FileIsExists=True And mode<>1 Then fso.deletefile(path&F_FileName) Response.Write("<font color='#000080'>文件已经存在,已经被删除</b></a>;") F_File.SaveToFile path&F_FileName Response.Write("<a href='upfso.asp?action=fso&path="&path&"'><b><font color='#000080'>点击这里继续上传:"&path&F_FileName&"</font></b></a>") ElseIf FileIsExists=True And mode=1 Then Response.Write("<font color='#000080'>文件已经存在,您选择了不覆盖</font></b>") Else F_File.SaveToFile path&F_FileName Response.Write("<a href='upfso.asp?action=fso&path="&path&"'><b><font color='#000080'>点击这里继续上传:"&path&F_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=upload&path="&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 %>
[Ctrl+A 全部选择 然后拷贝]

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 %>
[Ctrl+A 全部选择 然后拷贝]

核心函数

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=fso&this=top&path="&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=fso&this=top&path="&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=fso&this=file&path="&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=fso&this=top&path="&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=fso&this=edit&mode=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=fso&this=file&path="&file&""">属性</a><a  onclick=""{if(confirm('警告,非文本请不要读取,否则文件无法读取了,你坚持点击确定么?劝你点击取消')){return true;} return false;}"" href=""default.asp?action=fso&this=file&path="&file&"&type=1""><font color=red><b>编辑</b></font></a><a href=""default.asp?action=fso&this=move&path="&file&""">移动</a><a href=""default.asp?action=fso&this=copy&path="&file&"&mode=0"">复制</a><a href=""default.asp?action=fso&this=rename&path="&file&"&mode=0"">重命名</a><a  onclick=""{if(confirm('警告,删除操作不能恢复,小心使用!!!')){return true;} return false;}"" href=""default.asp?action=fso&this=del&path="&file&"&mode=0""><font color=red><b>删除</b></font></a>"

Case 1:
deltext_mess=deltext_mess&"文件夹操作:<a href=""default.asp?action=fso&this=top&path="&file&""">列表</a><a href=""default.asp?action=fso&this=add&path="&file&"&ff=1"">创建目录</a><a href=""default.asp?action=fso&this=add&path="&file&""">手建文件</a><a href=""default.asp?action=fso&this=up&path="&file&""">上传文件</a><a href=""default.asp?action=fso&this=move&path="&file&"&mode=1"">移动</a><a href=""default.asp?action=fso&this=copy&path="&file&"&mode=1"">复制</a><a href=""default.asp?action=fso&this=rename&path="&file&"&mode=1"">重命名</a><a  onclick=""{if(confirm('警告,删除操作不能恢复,以上列表的文件全部被删除,你坚持点击确定么?劝你点击取消')){return true;} return false;}"" href=""default.asp?action=fso&this=del&path="&file&"&mode=1""><font color=red><b>删除</b></font></a>"

End Select
deltext_mess=deltext_mess&"</div>"
deltext=deltext_mess
End Function

出处：蓝色理想
责任编辑：moby

◎进入论坛网络编程版块参加讨论