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