FSO操作文件系统

谢绝转载

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,Z<a class="channel_keylink" href="http://www.ggbing.com/ip">IP</a>,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) =

[1] [2] [3]  下一页

Copyright ＠ 2007-2012 敏韬网(敏而好学，文韬武略--MinTao.Net)（学习笔记） Inc All Rights Reserved.
闵涛 E_mail:admin@mintao.net(欢迎提供学习资源)

鄂公网安备 42011102001154号

站长：MinTao ICP备案号：鄂ICP备11006601号-18