标题: VBScript实现ZIP文件的压缩或解压(ZipCompressor)
作者: Demon
链接: https://demon.tw/copy-paste/vbscript-zipcompressor.html
版权: 本博客的所有文章,都遵守“署名-非商业性使用-相同方式共享 2.5 中国大陆”协议条款。
用了一段时间的Python后,发现VBScript竟然写得不是那么顺手,由于要实现脚本的压缩或者解压,本来觉得用Python来写说不定会方便些,可是想到这个脚本程序主要面对的是非编程人员,总不能要求他们也去安装Python吧,更何况大多数用户对于安装新软件会有抵触情绪。
不过一定要解决这个问题,也不是不可能的,我们可以把Python解释器和库文件打包一起发送给用户,比如可以通过py2exe这个实用工具。
好了,扯多了,今天讲的是使用WScript/VBScript来实现这个功能,Windows系统自带WScript/VBScript环境,妥妥的:-)
通常情况下系统会自带有压缩解压工具,最典型的就是makecab命令,以及可以使用其图形化界面iexpress,打开“开始”菜单,在“运行”对话框中输入iexpress,即可打开“IExpress Wizard”。当然配合makecab压缩命令使用的还有expand解压命令,关于这些命令的详细使用网上有很多我就不多说了,这里简单举个例子。
1. 建立一张要压缩的文件的压缩清单,我们这里将其命名为list.txt
,然后存储到C:
盘:
C:\Windows\notepad.exe C:\Windows\System32\drivers\etc\hosts
2. 输入下面的VBScript代码(*.vbs):
Option Explicit Dim WshShell Set WshShell = WSH.CreateObject("WScript.Shell") WshShell.Run "%comspec%" & _ " /c makecab /F ""C:\list.txt""" & _ " /D COMPRESSIONTYPE=LZX /D COMPRESSIONMEMORY=21" & _ " /D CABINETNAMETEMPLATE=Sample.CAB" Set WshShell = Nothing
3. 执行上述vbs代码,然后就会在当前目录下生成setup.rpt、setup.inf文件以及文件夹disk1,里面有我们所需要的压缩文件Sample.CAB,当然如果需要另外选择压缩文件的名称,可以修改CABINETNAMETEMPLATE
参数值。
当然这里使用了WScript.Shell
组件调用了命令行,可能有些朋友不太喜欢这种调用命令行的方式,其实还有一种方法可以直接通过系统自带的ActiveX控件来实现压缩或者解压缩,而且压缩文件格式还是更通用的zip。
回忆一下,刚安装的Windows XP系统(或者以上版本),再未安装任何压缩解压软件时,系统是可以打开或者解压zip文件的,充分说明了肯定是有办法调用系统这个功能的,通过《Can Windows’ built-in ZIP compression be scripted?》和《Handy vbscript functions for dealing with zip files and folders.》这两篇文章,得知这个功能可以通过Shell.Application
的CopyHere
来实现。
为此我改写了相关代码,实现了VBScript的ZipCompressor类,先看相关代码:
' ' Copyright (c) 2012-2013 WangYe. All rights reserved. ' ' Author: WangYe ' Site: http://wangye.org ' This code is distributed under the BSD license ' ' For more information please visit ' http://wangye.org/blog/archives/767/ ' ' References: ' http://www.techcoil.com/blog/handy-vbscript-functions-for-dealing-with-zip-files-and-folders/ ' http://stackoverflow.com/questions/30211/can-windows-built-in-zip-compression-be-scripted ' Class ZipCompressor Private objFileSystemObject Private objShellApplication Private objWScriptShell Private objScriptingDictionary Private objWMIService Private COPY_OPTIONS Private Sub Class_Initialize() Set objFileSystemObject = WSH.CreateObject("Scripting.FileSystemObject") Set objShellApplication = WSH.CreateObject("Shell.Application") Set objWScriptShell = WSH.CreateObject("WScript.Shell") Set objScriptingDictionary = WSH.CreateObject("Scripting.Dictionary") Dim strComputer strComputer = "." Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2") ' COPY_OPTIONS ' 4 Do not display a progress dialog box. ' 16 Respond with "Yes to All" for ' any dialog box that is displayed. ' 512 Do not confirm the creation of a new ' directory if the operation requires one to be created. ' 1024 Do not display a user interface if an error occurs. COPY_OPTIONS = 4 + 16 + 512 + 1024 End Sub Private Sub Class_Terminate() Set objWMIService = Nothing objScriptingDictionary.RemoveAll Set objScriptingDictionary = Nothing Set objWScriptShell = Nothing Set objShellApplication = Nothing Set objFileSystemObject = Nothing End Sub Private Sub makeEmptyZipFile(pathToZipFile) Dim file Set file = objFileSystemObject.CreateTextFile(pathToZipFile) file.Write Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, 0) file.Close End Sub Private Function pathToAbsolute(fileName) Dim i, file, files files = Split(fileName, ";") ReDim tmpFiles(UBound(files)) i = 0 For Each file in files If file<>"" Then file = objWScriptShell.ExpandEnvironmentStrings(file) file = objFileSystemObject.GetAbsolutePathName(file) tmpFiles(i) = file i = i+1 End If Next If i-1 > 0 And i-1 < UBound(files) Then ReDim Preserve tmpFiles(i-1) pathToAbsolute = Join(tmpFiles, ";") Erase tmpFiles End Function Private Function pathCombine(fileName, nextFileName) Dim files, lastIndex files = Split(fileName, "\") lastIndex = UBound(files) If files(lastIndex)<>"" Then lastIndex = lastIndex + 1 ReDim Preserve files(lastIndex) End If files(lastIndex) = nextFileName pathCombine = Join(files, "\") Erase files End Function Private Function pathSplit(fileName) Dim fileSplitted(2) fileSplitted(0) = objFileSystemObject.GetDriveName(fileName) fileSplitted(2) = objFileSystemObject.GetFileName(fileName) fileSplitted(1) = Mid(fileName, Len(fileSplitted(0))+1, _ Len(fileName) - Len(fileSplitted(0)) - Len(fileSplitted(2))) pathSplit = fileSplitted End Function Private Function pathSplitForQuery(fileName) Dim fileSplitted fileSplitted = pathSplit(fileName) fileSplitted(1) = Replace(fileSplitted(1), "\", "\\") If Right(fileSplitted(1), 2) <> "\\" Then fileSplitted(1) = fileSplitted(1) & "\\" End If ' http://msdn.microsoft.com/en-us/library/windows/desktop/aa392263(v=vs.85).aspx fileSplitted(2) = Replace(fileSplitted(2), "_", "[_]") fileSplitted(2) = Replace(fileSplitted(2), "*", "%") fileSplitted(2) = Replace(fileSplitted(2), "?", "_") pathSplitForQuery = fileSplitted End Function Private Function buildQuerySQL(fileName) Dim fileSplitted, file, ext fileSplitted = pathSplitForQuery(fileName) Dim lastDotIndex file = "%" : ext = "%" If fileSplitted(2)<>"" Then lastDotIndex = InStrRev(fileSplitted(2), ".") file = fileSplitted(2) End If If lastDotIndex>0 Then ext = Mid(fileSplitted(2), _ lastDotIndex+1, Len(fileSplitted(2)) - lastDotIndex) file = Left(fileSplitted(2), Len(fileSplitted(2)) - Len(ext) - 1) End If ' http://msdn.microsoft.com/en-us/library/windows/desktop/aa387236(v=vs.85).aspx buildQuerySQL = "SELECT * FROM CIM_DataFile" & _ " WHERE Drive='" & fileSplitted(0) & "' AND" & _ " (FileName LIKE '" & file & "') AND" & _ " (Extension LIKE '" & ext & "') AND" & _ " (Path='" & fileSplitted(1) &"')" End Function Private Function deleteFile(fileName) deleteFile = False If objFileSystemObject.FileExists(fileName) Then objFileSystemObject.DeleteFile fileName deleteFile = True End If End Function Private Sub compress_(ByVal fileName, ByRef zipFile) Dim objFile, srcFile, srcFiles srcFiles = Split(fileName, ";") Dim colFiles ' http://msdn.microsoft.com/en-us/library/bb787866(VS.85).aspx For Each srcFile In srcFiles If objFileSystemObject.FolderExists(srcFile) Then Set objFile = objShellApplication.NameSpace(srcFile) If Not (objFile Is Nothing) Then zipFile.CopyHere objFile.Items, COPY_OPTIONS Do Until objFile.Items.Count <= zipFile.Items.Count WScript.Sleep(200) Loop End If Set objFile = Nothing ElseIf objFileSystemObject.FileExists(srcFile) Then zipFile.CopyHere srcFile, COPY_OPTIONS WScript.Sleep(200) Else Set colFiles = objWMIService.ExecQuery(buildQuerySQL(srcFile)) For Each objFile in colFiles srcFile = objFile.Name zipFile.CopyHere srcFile, COPY_OPTIONS WScript.Sleep(200) Next Set colFiles = Nothing End If Next End Sub Public Sub add(fileName) objScriptingDictionary.Add pathToAbsolute(fileName), "" End Sub ' Private Function makeTempDir() ' Dim tmpFolder, tmpName ' tmpFolder = objFileSystemObject.GetSpecialFolder(2) ' tmpName = objFileSystemObject.GetTempName() ' makeTempDir = pathCombine(tmpFolder, tmpName) ' objFileSystemObject.CreateFolder makeTempDir ' End Function Public Function compress(srcFileName, desFileName) Dim srcAbsFileName, desAbsFileName srcAbsFileName = "" If srcFileName<>"" Then srcAbsFileName = pathToAbsolute(srcFileName) End If desAbsFileName = pathToAbsolute(desFileName) If objFileSystemObject.FolderExists(desAbsFileName) Then compress = -1 Exit Function End If ' That zip file already exists - deleting it. deleteFile desAbsFileName makeEmptyZipFile desAbsFileName Dim zipFile Set zipFile = objShellApplication.NameSpace(desAbsFileName) If srcAbsFileName<>"" Then compress_ srcAbsFileName, zipFile End If compress = zipFile.Items.Count Dim objKeys, i objKeys = objScriptingDictionary.Keys For i = 0 To objScriptingDictionary.Count -1 compress_ objKeys(i), zipFile Next compress = compress + i Set zipFile = Nothing End Function Public Function decompress(srcFileName, desFileName) Dim srcAbsFileName, desAbsFileName srcAbsFileName = pathToAbsolute(srcFileName) desAbsFileName = pathToAbsolute(desFileName) If Not objFileSystemObject.FileExists(srcAbsFileName) Then decompress = -1 Exit Function End If If Not objFileSystemObject.FolderExists(desAbsFileName) Then decompress = -1 Exit Function End If Dim zipFile, objFile Set zipFile = objShellApplication.NameSpace(srcAbsFileName) Set objFile = objShellApplication.NameSpace(desAbsFileName) objFile.CopyHere zipFile.Items, COPY_OPTIONS Do Until zipFile.Items.Count <= objFile.Items.Count WScript.Sleep(200) Loop decompress = objFile.Items.Count Set objFile = Nothing Set zipFile = Nothing End Function End Class
初步实现了压缩和解压的功能,关于具体的使用方法可以参考下面的示例:
压缩示例:
Dim zip Set zip = New ZipCompressor ' 方法1 压缩文件 zip.compress "C:\Windows\notepad.exe", "notepad.zip" ' 方法2 压缩文件夹(包含子文件或文件夹) zip.compress "C:\Windows\System32\drivers\etc", "etc.zip" ' 方法3 使用环境变量及通配符压缩文件 zip.compress "%WINDIR%\*.log", "log.zip" ' 方法4 动态添加压缩 zip.add "*.pdf" zip.add "C:\Windows\notepad.exe" zip.add "%WINDIR%\*.log" zip.add "C:\Windows\System32\drivers\etc" zip.compress "", "sample.zip" ' 方法5 路径分割方式压缩,以;分割 zip.compress _ "C:\Windows\KB*.log;C:\Windows\Notepad.exe;%WINDIR%\System32\drivers\etc", _ "C:\sample.zip" Set zip = Nothing
解压示例:
Dim zip Set zip = New ZipCompressor ' 需要在D盘建立文件夹extract zip.decompress("sample.zip", "D:\extract") Set zip = Nothing
假如出现“系统找不到指定的文件”错误,多是因为系统缺少zipfldr.dll组件,这种情况多出现在精简优化版的Windows系统上,解决的办法也很简单,下载zipfldr.dll,然后调用regsvr32
注册即可。
为了方便群众,我将适用于Windows XP的zipfldr.dll打包发在这儿zipfldr.dll – Windows XP适用 (9)供大家下载使用,下载后解压运行setup.bat即可。
原文链接:http://wangye.org/blog/archives/767/
赞赏微信赞赏支付宝赞赏
随机文章:
用xmlhttp抓取网页,返回gzip压缩后的数据后,怎么还原呢,网上建议去掉Accept-Encoding: gzip, deflate,但这个指标不治本,有的网站就是强制定义Accept-Encoding: identity可返回的数据还是gzip压缩后的数据,c#和php都有现成的函数用来解压,vbs真感觉力不从心了,现在的做法就是把压缩回来的数据保存成zip文件,然后调用winzip解压还原内容,还有其他的方法没有?
直接用vb6写一个com dll,要什么功能都可以无所不能,多线程标准dl调用。
兄弟,那你加油,写好了记得分享一份