VBScript实现ZIP文件的压缩或解压(ZipCompressor)

用了一段时间的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/

赞赏

微信赞赏支付宝赞赏

随机文章:

1. 你可以分配多大的内存?
2. 吞噬者批处理编写器
3. getElementsByName的用法
4. VBS转EXE工具：VbsEdit
5. Windows 10 LTSC 2019 KMS激活

这篇文章发布于 2012年10月22日，星期一，15:47，归类于 复制粘贴。 您可以跟踪这篇文章的评论通过 RSS 2.0 feed。 您可以留下评论，或者从您的站点trackback。