【Asp技巧】Asp网站目录打包与解包

ASP将整个目录所有文件打包为二进制mdb数据库文件

打包程序:

'On Error Resume Next '容错处理
Server.ScriptTimeOut = 300 '定义脚本超时时间

Dim Fso, Rs, Conn, Stream, AdoCataLog '定义用到的组件
Set Fso = Server.CreateObject("Scripting.FileSystemObject")
Set Rs = Server.CreateObject("AdoDB.RecordSet")
Set Conn = Server.CreateObject("AdoDB.Connection")
Set Stream = Server.CreateObject("AdoDB.Stream")
Set AdoCataLog = Server.CreateObject("AdoX.CataLog")

FileToMdb Server.MapPath("/") '打包根目录
Response.Write "打包完成! 完成时间:" & Now()
Response.End
'------------------------------------------------------------------
Function FileToMdb(ThePath)
Dim PackPath, ConnStr
PackPath = Server.MapPath("DataPack.mdb")
ConnStr = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & PackPath

If Fso.FileExists(PackPath) Then Fso.DeleteFile PackPath,True '删除旧的数据库文件

AdoCataLog.Create ConnStr
Conn.Open ConnStr '建立数据库连接
Conn.Execute("Create Table FileData(Id int IDENTITY(0,1) PRIMARY KEY CLUSTERED, ThePath VarChar, FileContent Image)")
    Stream.Open
    Stream.Type = 1
        Rs.Open "FileData", Conn, 3, 3
        FsoTreeForMdb ThePath '调用递归搜索文件并加入数据库
        'AddFileToMdb  Server.MapPath("index.html")
        'FsoTreeForMdb Server.MapPath("a")
        Rs.Close
    Stream.Close
Conn.Close
End Function
'------------------------------------------------------------------
Function AddFileToMdb(ThePath) '添加文件到数据库
Stream.LoadFromFile(ThePath) '载入文件
Rs.AddNew '添加新纪录
Rs("ThePath") = Replace(Mid(ThePath,4) ,Mid(Server.MapPath("/"),4) ,"") '添加文件路径
Rs("FileContent") = Stream.Read() '添加文件数据
Rs.Update '更新数据库
End Function
'------------------------------------------------------------------
Function FsoTreeForMdb(ThePath) '递归搜索文件并加入数据库
Dim Item, TheFolder
If Fso.FolderExists(ThePath) = False Then '判断目录是否存在
    Response.Write ThePath & " 目录不存在或无法访问!"
    Response.End
Else
    Set TheFolder = Fso.GetFolder(ThePath)
    For Each Item In TheFolder.SubFoldeRs
        FsoTreeForMdb Item.Path
    Next
    For Each Item In TheFolder.Files '循环读取文件
        If Item.Name "DataPack.mdb" And Item.Name "DataPack.ldb" Then '排除数据库文件
            AddFileToMdb Item.Path '添加文件到数据库
        End If
    Next
End If
End Function
%>

解包程序:

'On Error Resume Next
Server.ScriptTimeOut = 300

Dim Fso, Rs, Stream, Conn '定义需要的组件
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Rs = CreateObject("ADODB.RecordSet")
Set Stream = CreateObject("ADODB.Stream")
Set Conn = CreateObject("ADODB.Connection")

UnPackMdb Server.MapPath("DataPack.mdb")
Response.End
'------------------------------------------------------------------
Function CreateFolder(ThePath) '创建文件夹
Dim i
i = InStr(ThePath, "")
Do While i > 0
If Fso.FolderExists(Left(ThePath, i)) = False Then Fso.CreateFolder(Left(ThePath, i - 1))
If InStr(Mid(ThePath, i + 1), "") Then
    i = i + InStr(Mid(ThePath, i + 1), "")
Else
    i = 0
End If
Loop
End Function
'------------------------------------------------------------------
Function UnPackMdb(TheMdb)
Dim Str, TheFolder
Str = Server.MapPath("") & ""

If Fso.FileExists(TheMdb) = False Then
    Response.Write "数据库：" & TheMdb & " 不存在!"
    Response.end
End IF

Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & TheMdb & ";"
    Rs.Open "FileData", Conn, 1, 1
        Stream.Open
        Stream.Type = 1
            Do Until Rs.Eof
            TheFolder = Left(Rs("ThePath"), InStrRev(Rs("ThePath"), ""))
                If Fso.FolderExists(Str & TheFolder) = False Then
                    CreateFolder(Str & TheFolder)
                End If
            Stream.SetEos()
                If len(Rs("FileContent")) 0 Then
                    Stream.Write Rs("FileContent")
                End If
            Stream.SaveToFile Str & Rs("ThePath"), 2
            Rs.MoveNext
            Loop
        Stream.Close
    Rs.Close
Conn.Close

'If Fso.FileExists(TheMdb) Then Fso.DeleteFile TheMdb,True '删除旧的数据库文件
Response.Write "所有文件释放完毕! 完成时间:" & Now()
End Function
%>

文章来源于lcx.cc:【Asp技巧】Asp网站目录打包与解包