vbs mdb打包解包代码

pack.vbs 用来打包文件夹, 根目录为文件所在目录.

Dim n, ws, fsoX, thePath 
Set ws = CreateObject("WScript.Shell") 
Set fsoX = CreateObject("Scripting.FileSystemObject") 
thePath = ws.Exec("cmd /c cd").StdOut.ReadAll() & "\" 
i = InStr(thePath, Chr(13)) 
thePath = Left(thePath, i - 1) 
n = len(thePath) 
On Error Resume Next 
addToMdb(thePath) 
Wscript.Echo "当前目录已经打包完毕,根目录为当前目录" 
Sub addToMdb(thePath) 
Dim rs, conn, stream, connStr 
Set rs = CreateObject("ADODB.RecordSet") 
Set stream = CreateObject("ADODB.Stream") 
Set conn = CreateObject("ADODB.Connection") 
Set adoCatalog = CreateObject("ADOX.Catalog") 
connStr = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=Packet.mdb" 
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, rs, stream 
rs.Close 
Conn.Close 
stream.Close 
Set rs = Nothing 
Set conn = Nothing 
Set stream = Nothing 
Set adoCatalog = Nothing 
End Sub 
Function fsoTreeForMdb(thePath, rs, stream) 
Dim i, item, theFolder, folders, files 
sysFileList = "$" & WScript.ScriptName & "$Packet.mdb$Packet.ldb$" 
Set theFolder = fsoX.GetFolder(thePath) 
Set files = theFolder.Files 
Set folders = theFolder.SubFolders 
For Each item In folders 
fsoTreeForMdb item.Path, rs, stream 
Next 
For Each item In files 
If InStr(LCase(sysFileList), "$" & LCase(item.Name) & "$") <= 0 Then 
rs.AddNew 
rs("thePath") = Mid(item.Path, n + 2) 
stream.LoadFromFile(item.Path) 
rs("fileContent") = stream.Read() 
rs.Update 
End If 
Next 
Set files = Nothing 
Set folders = Nothing 
Set theFolder = Nothing 
End Function

unpack.vbs 用来解包文件包(Packet.mdb), 解开到当前目录.

Dim rs, ws, fso, conn, stream, connStr, theFolder 
Set rs = CreateObject("ADODB.RecordSet") 
Set stream = CreateObject("ADODB.Stream") 
Set conn = CreateObject("ADODB.Connection") 
Set fso = CreateObject("Scripting.FileSystemObject") 
connStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=Packet.mdb;" 

conn.Open connStr 
rs.Open "FileData", conn, 1, 1 
stream.Open 
stream.Type = 1 

On Error Resume Next 

Do Until rs.Eof 
theFolder = Left(rs("thePath"), InStrRev(rs("thePath"), "\")) 
If fso.FolderExists(theFolder) = False Then 
createFolder(theFolder) 
End If 
stream.SetEos() 
stream.Write rs("fileContent") 
stream.SaveToFile str & rs("thePath"), 2 
rs.MoveNext 
Loop 

rs.Close 
conn.Close 
stream.Close 
Set ws = Nothing 
Set rs = Nothing 
Set stream = Nothing 
Set conn = Nothing 

Wscript.Echo "所有文件释放完毕!" 

Sub 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)) 
End If 
If InStr(Mid(thePath, i + 1), "\") Then 
i = i + Instr(Mid(thePath, i + 1), "\") 
Else 
i = 0 
End If 
Loop 
End Sub 

打包下载地址 http://www.jb51.net/downtools/A%20SPAdmin%20V1.02.rar