[原创]发一个06年写的“FSO文件浏览器”
2008-11-28 21:59
260 查看
这是一个利用FSO集合对象编写的FSO文件浏览器（如果你非要说它是木马，我也不反对），在功能上仿照了“海洋顶端木马”设计，不过代码完全是重写的，没有使用如Shell.Application等容易造成杀毒软件误杀的组件。类似的工具网上有很多，本工具使用价值不是很大，但其中的很多代码自认为写的不错的。
主要功能包括：
磁盘信息查看
磁盘文件浏览
类似WindowsExplorer的操作方式
新建、删除、改名、复制、移动等基本文件操作
文本文件编辑
Stream方式文件下载
精简优化的无组件上传
文件打包/解包，一个文件夹可以完整地被打包/解包
下载地址1： http://download.csdn.net/source/818771
下载地址2： http://down.chinaz.com/soft/24456.htm
代码片断：
1. 文件打包/解包部分
'============================ 文件打包及解包过程 =============================
'文件打包
Sub Pack(ByVal FPath, ByVal sDbPath)
Server.ScriptTimeOut=900
Dim DbPath
If Right(sDbPath,4)=".mdb" Then
DbPath=sDbPath
Else
DbPath=sDbPath".mdb"
End If
If oFso.FolderExists(DbPath) Then
EchoBack "不能创建数据库文件！"&Replace(DbPath,"/","//")
Exit Sub
End If
If oFso.FileExists(DbPath) Then
oFso.DeleteFile DbPath
End If
If IsFolder(FPath) Then
RootPath=GetParentFolder(FPath)
If Right(RootPath,1)<>"/" Then RootPath=RootPath&"/"
Else
EchoBack "请输入文件夹路径！"
Exit Sub
End If
Dim oCatalog,connStr,DataName
Set conn=Server.CreateObject("ADODB.Connection")
Set oStream=Server.CreateObject("ADODB.Stream")
Set oCatalog=Server.CreateObject("ADOX.Catalog")
Set rs=Server.CreateObject("ADODB.RecordSet")
On Error Resume Next
connStr = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & DbPath
oCatalog.Create connStr
If Err Then
EchoBack "不能创建数据库文件！"&Replace(DbPath,"/","//")
Exit Sub
End If
Set oCatalog=Nothing
conn.Open connStr
conn.Execute("Create Table Files(ID int IDENTITY(0,1) PRIMARY KEY CLUSTERED, FilePath VarChar, FileData Image)")
oStream.Open
oStream.Type=1
rs.Open "Files",conn,3,3
DataName=Left(oFso.GetFile(DbPath).Name,InstrRev(oFso.GetFile(DbPath).Name,".")-1)
NoPackFiles=Replace(NoPackFiles,"<$datafile>",DataName)
FailFileList="" '打包失败的文件列表
PackFolder FPath
If FailFilelist="" Then
EchoClose "文件夹打包成功！"
Else
Response.Write "<link rel='stylesheet' type='text/css' href='?page=css'>"
Response.Write "<Script Language='JavaScript'>alert('文件夹打包完成！/n以下是打包失败的文件列表：');</Script>"
Response.Write "<body>"&Replace(FailFilelist,"|","<br>")"</body>"
End If
oStream.Close
rs.Close
conn.Close
End Sub
'添加文件夹（递归）
Sub PackFolder(FolderPath)
If Not IsFolder(FolderPath) Then Exit Sub
Dim oFolder,sFile,sFolder
Set oFolder=oFso.GetFolder(FolderPath)
For Each sFile In oFolder.Files
If InStr(NoPackFiles,"|"&sFile.Name"|")<1 Then
PackFile sFile.Path
End If
Next
Set sFile=Nothing
For Each sFolder In oFolder.SubFolders
PackFolder sFolder.Path
Next
Set sFolder=Nothing
End Sub
'添加文件
Sub PackFile(FilePath)
Dim RelPath
RelPath=Replace(FilePath,RootPath,"")
'Response.Write RelPath & "<br>"
On Error Resume Next
Err.Clear
Err=False
oStream.LoadFromFile FilePath
rs.AddNew
rs("FilePath")=RelPath
rs("FileData")=oStream.Read()
rs.Update
If Err Then
'一个文件打包失败
FailFilelist=FailFilelist&FilePath"|"
End If
End Sub
'===========================================================================
'文件解包
Sub UnPack(vFolderPath,DbPath)
Server.ScriptTimeOut=900
Dim FilePath,FolderPath,sFolderPath
FolderPath=vFolderPath
FolderPath=Trim(FolderPath)
If Mid(FolderPath,2,1)<>":" Then
EchoBack "路径格式错误，无法创建改目录！"
Exit Sub
End If
If Right(FolderPath,1)="/" Then FolderPath=Left(FolderPath,Len(FolderPath)-1)
Dim connStr
Set conn=Server.CreateObject("ADODB.Connection")
Set oStream=Server.CreateObject("ADODB.Stream")
Set rs=Server.CreateObject("ADODB.RecordSet")
connStr = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & DbPath
On Error Resume Next
Err=False
conn.Open connStr
If Err Then
EchoBack "数据库打开错误！"
Exit Sub
End If
Err=False
oStream.Open
oStream.Type=1
rs.Open "Files",conn,1,1
FailFilelist="" '清空失败文件列表
Do Until rs.EOF
Err.Clear
Err=False
FilePath=FolderPath"/"&rs("FilePath")
FilePath=Replace(FilePath,"//","/")
sFolderPath=Left(FilePath,InStrRev(FilePath,"/"))
If Not oFso.FolderExists(sFolderPath) Then
CreateFolder(sFolderPath)
End If
oStream.SetEos()
oStream.Write rs("FileData")
oStream.SaveToFile FilePath,2
If Err Then '添加失败文件项目
FailFilelist=FailFilelist&rs("FilePath").Value"|"
End If
rs.MoveNext
Loop
rs.Close
Set rs=Nothing
conn.Close
Set conn=Nothing
Set oStream=Nothing
If FailFilelist="" Then
EchoClose "文件解包成功！"
Else
Response.Write "<link rel='stylesheet' type='text/css' href='?page=css'>"
Response.Write "<Script Language='JavaScript'>alert('文件夹打包完成！/n以下是打包失败的文件列表，请检查');</Script>"
Response.Write "<body>"&Replace(FailFilelist,"|","<br>")"</body>"
End If
End Sub
'===========================================================================
2. 文件上传部分（单一文件）：
'保存上传文件
Sub Saveupload(ByVal FolderName)
If Not IsFolder(FolderName) Then
EchoClose "没有指定上传的文件夹！"
Exit Sub
End If
Dim Path,IsOverWrite
Path=FolderName
If Right(Path,1)<>"/" Then Path=Path&"/"
FileName=Replace(Request("filename"),"/","")
If Len(FileName)<1 Then
EchoBack "请选择文件并输入文件名！"
Exit Sub
End If
Path=Path
If LCase(Request("overwrite"))="true" Then
IsOverWrite=True
Else
IsOverWrite=False
End If
On Error Resume Next
Call MyUpload(Path,IsOverWrite)
If Err Then
EchoBack "文件上传失败！（可能是文件已存在）"
Else
EchoClose "文件上传成功!/n" & Replace(fileName, "/", "//")
End If
End Sub
'文件上传核心代码
Sub MyUpload(FilePath,IsOverWrite)
Dim oStream,tStream,FileName,sData,sSpace,sInfo,iSpaceEnd,iInfoStart,iInfoEnd,iFileStart,iFileEnd,iFileSize,RequestSize,bCrLf
RequestSize=Request.TotalBytes
If RequestSize<1 Then Exit Sub
Set oStream=Server.CreateObject("ADODB.Stream")
Set tStream=Server.CreateObject("ADODB.Stream")
With oStream
.Type=1
.Mode=3
.Open
.Write=Request.BinaryRead(RequestSize)
.Position=0
sData=.Read
bCrLf=ChrB(13)&ChrB(10)
iSpaceEnd=InStrB(sData,bCrLf)-1
sSpace=LeftB(sData,iSpaceEnd)
iInfoStart=iSpaceEnd+3
iInfoEnd=InStrB(iInfoStart,sData,bCrLf&bCrLf)-1
iFileStart=iInfoEnd+5
iFileEnd=InStrB(iFileStart,sData,sSpace)-3
sData="" '清空文件数据
iFileSize=iFileEnd-iFileStart+1
tStream.Type=1
tStream.Mode=3
tStream.Open
.Position=iFileStart-1
.CopyTo tStream,iFileSize
If IsOverWrite Then
tStream.SaveToFile FilePath,2
Else
tStream.SaveToFile FilePath
End If
tStream.Close
.Close
End With
Set tStream=Nothing
Set oStream=Nothing
End Sub
主要功能包括：
磁盘信息查看
磁盘文件浏览
类似WindowsExplorer的操作方式
新建、删除、改名、复制、移动等基本文件操作
文本文件编辑
Stream方式文件下载
精简优化的无组件上传
文件打包/解包，一个文件夹可以完整地被打包/解包
下载地址1： http://download.csdn.net/source/818771
下载地址2： http://down.chinaz.com/soft/24456.htm
代码片断：
1. 文件打包/解包部分
'============================ 文件打包及解包过程 =============================
'文件打包
Sub Pack(ByVal FPath, ByVal sDbPath)
Server.ScriptTimeOut=900
Dim DbPath
If Right(sDbPath,4)=".mdb" Then
DbPath=sDbPath
Else
DbPath=sDbPath".mdb"
End If
If oFso.FolderExists(DbPath) Then
EchoBack "不能创建数据库文件！"&Replace(DbPath,"/","//")
Exit Sub
End If
If oFso.FileExists(DbPath) Then
oFso.DeleteFile DbPath
End If
If IsFolder(FPath) Then
RootPath=GetParentFolder(FPath)
If Right(RootPath,1)<>"/" Then RootPath=RootPath&"/"
Else
EchoBack "请输入文件夹路径！"
Exit Sub
End If
Dim oCatalog,connStr,DataName
Set conn=Server.CreateObject("ADODB.Connection")
Set oStream=Server.CreateObject("ADODB.Stream")
Set oCatalog=Server.CreateObject("ADOX.Catalog")
Set rs=Server.CreateObject("ADODB.RecordSet")
On Error Resume Next
connStr = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & DbPath
oCatalog.Create connStr
If Err Then
EchoBack "不能创建数据库文件！"&Replace(DbPath,"/","//")
Exit Sub
End If
Set oCatalog=Nothing
conn.Open connStr
conn.Execute("Create Table Files(ID int IDENTITY(0,1) PRIMARY KEY CLUSTERED, FilePath VarChar, FileData Image)")
oStream.Open
oStream.Type=1
rs.Open "Files",conn,3,3
DataName=Left(oFso.GetFile(DbPath).Name,InstrRev(oFso.GetFile(DbPath).Name,".")-1)
NoPackFiles=Replace(NoPackFiles,"<$datafile>",DataName)
FailFileList="" '打包失败的文件列表
PackFolder FPath
If FailFilelist="" Then
EchoClose "文件夹打包成功！"
Else
Response.Write "<link rel='stylesheet' type='text/css' href='?page=css'>"
Response.Write "<Script Language='JavaScript'>alert('文件夹打包完成！/n以下是打包失败的文件列表：');</Script>"
Response.Write "<body>"&Replace(FailFilelist,"|","<br>")"</body>"
End If
oStream.Close
rs.Close
conn.Close
End Sub
'添加文件夹（递归）
Sub PackFolder(FolderPath)
If Not IsFolder(FolderPath) Then Exit Sub
Dim oFolder,sFile,sFolder
Set oFolder=oFso.GetFolder(FolderPath)
For Each sFile In oFolder.Files
If InStr(NoPackFiles,"|"&sFile.Name"|")<1 Then
PackFile sFile.Path
End If
Next
Set sFile=Nothing
For Each sFolder In oFolder.SubFolders
PackFolder sFolder.Path
Next
Set sFolder=Nothing
End Sub
'添加文件
Sub PackFile(FilePath)
Dim RelPath
RelPath=Replace(FilePath,RootPath,"")
'Response.Write RelPath & "<br>"
On Error Resume Next
Err.Clear
Err=False
oStream.LoadFromFile FilePath
rs.AddNew
rs("FilePath")=RelPath
rs("FileData")=oStream.Read()
rs.Update
If Err Then
'一个文件打包失败
FailFilelist=FailFilelist&FilePath"|"
End If
End Sub
'===========================================================================
'文件解包
Sub UnPack(vFolderPath,DbPath)
Server.ScriptTimeOut=900
Dim FilePath,FolderPath,sFolderPath
FolderPath=vFolderPath
FolderPath=Trim(FolderPath)
If Mid(FolderPath,2,1)<>":" Then
EchoBack "路径格式错误，无法创建改目录！"
Exit Sub
End If
If Right(FolderPath,1)="/" Then FolderPath=Left(FolderPath,Len(FolderPath)-1)
Dim connStr
Set conn=Server.CreateObject("ADODB.Connection")
Set oStream=Server.CreateObject("ADODB.Stream")
Set rs=Server.CreateObject("ADODB.RecordSet")
connStr = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & DbPath
On Error Resume Next
Err=False
conn.Open connStr
If Err Then
EchoBack "数据库打开错误！"
Exit Sub
End If
Err=False
oStream.Open
oStream.Type=1
rs.Open "Files",conn,1,1
FailFilelist="" '清空失败文件列表
Do Until rs.EOF
Err.Clear
Err=False
FilePath=FolderPath"/"&rs("FilePath")
FilePath=Replace(FilePath,"//","/")
sFolderPath=Left(FilePath,InStrRev(FilePath,"/"))
If Not oFso.FolderExists(sFolderPath) Then
CreateFolder(sFolderPath)
End If
oStream.SetEos()
oStream.Write rs("FileData")
oStream.SaveToFile FilePath,2
If Err Then '添加失败文件项目
FailFilelist=FailFilelist&rs("FilePath").Value"|"
End If
rs.MoveNext
Loop
rs.Close
Set rs=Nothing
conn.Close
Set conn=Nothing
Set oStream=Nothing
If FailFilelist="" Then
EchoClose "文件解包成功！"
Else
Response.Write "<link rel='stylesheet' type='text/css' href='?page=css'>"
Response.Write "<Script Language='JavaScript'>alert('文件夹打包完成！/n以下是打包失败的文件列表，请检查');</Script>"
Response.Write "<body>"&Replace(FailFilelist,"|","<br>")"</body>"
End If
End Sub
'===========================================================================
2. 文件上传部分（单一文件）：
'保存上传文件
Sub Saveupload(ByVal FolderName)
If Not IsFolder(FolderName) Then
EchoClose "没有指定上传的文件夹！"
Exit Sub
End If
Dim Path,IsOverWrite
Path=FolderName
If Right(Path,1)<>"/" Then Path=Path&"/"
FileName=Replace(Request("filename"),"/","")
If Len(FileName)<1 Then
EchoBack "请选择文件并输入文件名！"
Exit Sub
End If
Path=Path
If LCase(Request("overwrite"))="true" Then
IsOverWrite=True
Else
IsOverWrite=False
End If
On Error Resume Next
Call MyUpload(Path,IsOverWrite)
If Err Then
EchoBack "文件上传失败！（可能是文件已存在）"
Else
EchoClose "文件上传成功!/n" & Replace(fileName, "/", "//")
End If
End Sub
'文件上传核心代码
Sub MyUpload(FilePath,IsOverWrite)
Dim oStream,tStream,FileName,sData,sSpace,sInfo,iSpaceEnd,iInfoStart,iInfoEnd,iFileStart,iFileEnd,iFileSize,RequestSize,bCrLf
RequestSize=Request.TotalBytes
If RequestSize<1 Then Exit Sub
Set oStream=Server.CreateObject("ADODB.Stream")
Set tStream=Server.CreateObject("ADODB.Stream")
With oStream
.Type=1
.Mode=3
.Open
.Write=Request.BinaryRead(RequestSize)
.Position=0
sData=.Read
bCrLf=ChrB(13)&ChrB(10)
iSpaceEnd=InStrB(sData,bCrLf)-1
sSpace=LeftB(sData,iSpaceEnd)
iInfoStart=iSpaceEnd+3
iInfoEnd=InStrB(iInfoStart,sData,bCrLf&bCrLf)-1
iFileStart=iInfoEnd+5
iFileEnd=InStrB(iFileStart,sData,sSpace)-3
sData="" '清空文件数据
iFileSize=iFileEnd-iFileStart+1
tStream.Type=1
tStream.Mode=3
tStream.Open
.Position=iFileStart-1
.CopyTo tStream,iFileSize
If IsOverWrite Then
tStream.SaveToFile FilePath,2
Else
tStream.SaveToFile FilePath
End If
tStream.Close
.Close
End With
Set tStream=Nothing
Set oStream=Nothing
End Sub
内容来自用户分享和网络整理，不保证内容的准确性，如有侵权内容，可联系管理员处理 
相关文章推荐
- Thin的DateChooser代码学习(关于js的函数参数为一个完整的函数以及“对象不支持此属性或方法”错误的解决)（原创，转载请声明）
- python中如何判断一个变量的数据类型？(原创)
- [原创]如何写一个完善的c++异常处理类
- 使用C#编写一个计时器(原创)
- 一个调试工具编写的发现（原创）
- （原创）胡总讲的一个猫狗情未了的感人故事
- [原创]Enterprise Library深入解析与灵活应用（4）：创建一个自定义Exception Handler改变ELAB的异常处理机制
- 自己写的一个数据库操作类(C#)[原创]
- 简单封装的一个彩色进度条【原创】
- [原创]一个C#病毒源代码的分析
- 仿照everything写的一个超级速查 原创
- 一个二维数组小函数 .net函数[彭彭原创]
- 原创：一个百色人的IT之路—杭州之行(第四篇)
- 原创:一个带阴影的Border(WPF控件)成品
- [原创]一个关于日期比较与排列的代码!
- （原创）一个轻量级、高性能的消息分发器的实现
- [原创] ASP.NET 中如何弹出提示窗口然后导向另外一个页面
- 一个IT人的爱恋（原创）
- Revit二次开发之判断一个族实例是否基于面创建【比目鱼原创】
- 基于ajax的一个无限树型菜单【原创】