FSO操作文件系統

2020-07-27 13:29:07

字體：大中小

來源：轉載

供稿：網友

實現功能：
文件(夾)目錄列表提供了查閱目錄下面的文件和文件夾
文件寫,創,刪提供了編輯,刪除文件(文件夾)的操作
創建文件夾/文件針對創建文件夾(文件)而設置.
上傳文件您可以模擬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&"/","http://","/") 
                    Else 
                    path=Replace(Lcase(path),"/","/") 
                    path=Replace(path&"/","http://","/") 
                    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"),"http://","/") 
            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 
        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&"/","http://","/")&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,"http://","/") 
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,"http://","/") 
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 & "文件大?。?nbsp;" & 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 