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 

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