【ASP】打包目录所有文件为2进制Mdb文件

/ 0评 / 0

[php]
打包程序:

<%
'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
%>
[/php]

[php]
解包程序:

<%
'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
%>
[/php]
转自:http://lcx.cc/?i=542

发表评论

电子邮件地址不会被公开。 必填项已用*标注