vbs mdb打包解包代码打包
作者 佚名
来源 ASP编程
浏览
发布时间 2013-07-09
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 |
凌众科技专业提供服务器租用、服务器托管、企业邮局、虚拟主机等服务,公司网站:http://www.lingzhong.cn 为了给广大客户了解更多的技术信息,本技术文章收集来源于网络,凌众科技尊重文章作者的版权,如果有涉及你的版权有必要删除你的文章,请和我们联系。以上信息与文章正文是不可分割的一部分,如果您要转载本文章,请保留以上信息,谢谢! |
你可能对下面的文章感兴趣
关于vbs mdb打包解包代码打包的所有评论