实现功能： 文件(夹)目录列表 提供了查阅目录下面的文件和文件夹 文件 写,创,删 提供了编辑,删除文件(文件夹)的操作 创建文件夹/文件 针对创建文件夹(文件)而设置. 上传文件 您可以模拟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-Zd]" 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-Zd]" 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

　　推荐阅读

　　采集原理---采集技术篇---XMLHTTP

最近一段时间，采集很热门，从新闻小偷，到音乐小偷，到新闻采集，Flash采集，都有他的踪影，现在还有很多的人对采集都很感兴趣，为了服务大家，我也正在写一套采集程序，名字为 心意采集程序 ，现在我讲一下，采集>>>详细阅读

本文标题：FSO操作文件系统

地址：http://www.17bianji.com/kaifa2/ASP/33113.html

 1/2    1