FSO操作文件系统

　　实现功能：

　　文件(夹)目录列表提供了查阅目录下面的文件和文件夹

　　文件写,创,删提供了编辑,删除文件(文件夹)的操作

　　创建文件夹/文件针对创建文件夹(文件)而设置.

　　上传文件您可以模拟FTP上传,文件大小,类型不受限制.

　　有兴趣的自己体验，出现任何问题我均不承担任何后果，在此说，我没多少时间上网，经常也顾不过来，是看到最近经常有人问这方面的问题，就发上来，希望有所帮助。

　　upfso.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

　　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

　　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

　　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

　　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

　　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=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>"

　　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>"

　　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>

　　<%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

教程首页更多教程