【ASP】打包目录所有文件为2进制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
%>