<%
'*****************************************************
'说明
'用途：
'1、用于网站备份
'2、打包上传、下载
'服务器要求：
'1、fso
'2、数据库
'3、adodbstream
'各位朋友可以任意修改和转载,但希望能保留这段信息!
'作者:何足道
'博客:蓝光 BlueShine
'欢迎访问我的博客:http://www.blue-sun.cn
'DBName 数据库名,WillPath 打包或解包位置,Operation 操作方式,有两个参数:press\repress
'两个方法:press和repress
'*****************************************************

Class Web_Bag
Dim DBName,WillPath,Operation
Dim Conn,FS,tStream,RS,TargetFolder
Dim PathLendth,Ldb,DBName_all

Private Sub Initialize()
if DBName="" then DBName="data.mdb"
if WillPath="" then WillPath="."
if Operation="" then Operation="press"
Ldb=left(DBName,instr(DBName,"."))
DBName_all=Server.Mappath(DBName)
WillPath=Server.Mappath(WillPath)

Set FS= Server.CreateObject("Scripting.FileSystemObject")
If FS.FileExists(DBName_all) and lcase(trim(Operation))<>"repress" Then FS.DeleteFile(DBName_all)
If not FS.FileExists(DBName_all) then CreateDB(DBName_all)
Set TargetFolder=FS.Getfolder(WillPath)
PathLendth=len(TargetFolder.path)
set Conn= Server.CreateObject("ADODB.Connection")
Con="provider=microsoft.jet.oledb.4.0;data source="&DBName_all
Conn.open con
sql="select * from filemes where id is null"
Set RS=Server.CreateObject("adodb.recordset")
RS.open sql,conn,1,3

Set tStream= Server.CreateObject("ADODB.Stream")
tStream.Mode=3
tStream.type=1
End Sub

Private Sub CreateDB(path)
Set Conn = Server.CreateObject( "ADOX.Catalog" )
Conn.Create "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & path

set Conn= Server.CreateObject("ADODB.Connection")
Con="provider=microsoft.jet.oledb.4.0;data source="&DBName_all
Conn.open con
sql="create table filemes(id int IDENTITY PRIMARY KEY,path varchar(255) NOT NULL,content image)"
Conn.Execute(sql)
End Sub

Private Sub GetFD(FolderPath)
for each Sub_Folder in FolderPath.SubFolders
WriteFiletoBase(Sub_Folder)
GetFD(Sub_Folder)
next
End Sub

Private Sub WriteFiletoBase(FolderPath)
For Each TargetFile in FolderPath.files
TargetFilepath=TargetFile.path
if lcase(TargetFile.path)<>lcase(server.mappath(DBName)) and lcase(TargetFile.path)<>lcase(server.mappath(Ldb&"ldb")) then
tStream.Open
tStream.Position = 0
tStream.LoadFromFile(TargetFilepath)
FileBIN=tStream.read()
tStream.Close
RS.addnew
RS("content").appendchunk FileBIN
RS("path")=right(TargetFilepath,len(TargetFilepath)-PathLendth-1)
RS.update
End if
Next
End Sub

private sub Terminate()
RS.close
set RS=Nothing
Conn.close
set Conn=Nothing
set tStream=Nothing
set FS=Nothing
DBName=""
WillPath=""
Operation=""
end sub

Private Sub createFolder(fileName)
set upl=Server.CreateObject("Scripting.FileSystemObject")
dim tmpF,tmpFC,tmpD,i,upl
tmpFC=""
tmpD=""
tmpF=split(fileName,"\")
for i=0 to ubound(tmpF)-1
tmpFC=tmpFC & tmpD & tmpF(i)
if upl.FolderExists(Server.MapPath(tmpFC))=False Then
upl.CreateFolder Server.MapPath(tmpFC)
end if
tmpD="\"
next

end sub

Private Sub WriteFilefromBase()
sql="select * from filemes"
RS.close
RS.open sql,conn,1,3
while not rs.eof
createFolder(RS("path"))
tStream.Open
tStream.Position = 0
if lenB(RS("content"))<>0 then tStream.write RS("content")
tStream.savetofile server.MapPath(RS("path")),2
tStream.Close
RS.movenext
wend

End sub

public Sub Press()
Initialize()
WriteFiletoBase(TargetFolder)
GetFD(TargetFolder)
Terminate()
end sub

Public Sub RePress()
Initialize()
WriteFilefromBase()
Terminate()
end sub
End Class
%>

<!--#include file="pressandre.asp"-->
<% set kk=new Web_Bag '实例化一个对象
kk.operation="press" '设定操作方式
kk.dbname="2007-6-9.bak" '设定文件名
kk.willpath="." '设定被打包的内容路径
kk.press() '调用压缩方法
%>

<!--#include file="pressandre.asp"-->
<% set kk=new Web_Bag'实例化一个对象
kk.operation="repress" '设定操作方式
kk.dbname="2007-6-9.bak"'设定文件名,确定这个文件是存在的
kk.willpath="." '设定解压到那个目录
kk.repress() '调用解压方法
%>