提醒：本页面将不再更新、维护或者支持，文章、评论所叙述内容存在时效性，涉及技术细节或者软件使用方面不保证能够完全有效可操作，请谨慎参考！

用了一段时间的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打包发在这儿[download id="1144"]供大家下载使用，下载后解压运行setup.bat即可。

2014年8月14日更新

应网友要求我这边提供一个命令行版本，将下面代码和 Class ZipCompressor 放在一起。 

' TODO: Copy & Paste Class ZipCompressor Here

Const strComputer = "."

Function IsAdminApprovalModeEnabled()
    IsAdminApprovalModeEnabled = False
    Dim objWMIService, colOperationSystems, objOperationSystem
    Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
    Set colOperationSystems = objWMIService.ExecQuery ("Select * from Win32_OperatingSystem")
        For Each objOperationSystem In colOperationSystems
            If CInt(Left(objOperationSystem.Version, 1)) > 5 Then
                IsAdminApprovalModeEnabled = True
                Exit Function
            End If
        Next
    Set colOperationSystems = Nothing
    Set objWMIService = Nothing
End Function

Sub ForceCScriptExecution(ByVal blnAdjustTokenPrivilegeRequired)
    ' https://stackoverflow.com/questions/4692542/force-a-vbs-to-run-using-cscript-instead-of-wscript
    ' http://www.winhelponline.com/articles/185/1/VBScripts-and-UAC-elevation.html
    Dim Arg, Str
    If Not LCase( Right( WScript.FullName, 12 ) ) = "\cscript.exe" Then
        For Each Arg In WScript.Arguments
            If InStr( Arg, " " ) Then Arg = """" & Arg & """"
            Str = Str & " " & Arg
        Next
 
        If blnAdjustTokenPrivilegeRequired And IsAdminApprovalModeEnabled() Then
            CreateObject( "Shell.Application" ).ShellExecute _
                "cscript.exe","//nologo """ & _
                WScript.ScriptFullName & _
                """ " & Str, "", "runas", 1
        Else
 
            CreateObject( "WScript.Shell" ).Run _
            "cscript //nologo """ & _
            WScript.ScriptFullName & _
            """ " & Str
 
        End If
        WScript.Quit
    End If
End Sub

Public Function PathAddBackslash(ByRef objFileSystemObject, strFileName)
    PathAddBackslash = strFileName
    If objFileSystemObject.FolderExists(strFileName) Then
      Dim last
      ' 文件夹存在
      ' 截取最后一个字符
      last = Right(strFileName, 1)
      If last<>"\" And last<>"/" Then
        PathAddBackslash = strFileName & "\"
      End If
    End If
End Function
 
 
Function VBMain(colArguments)
    ForceCScriptExecution True
    If WScript.Arguments.Count < 1 Then
        WScript.Echo "Compress Files to Zip File or Decompress Zip File" & vbCrLf
        WScript.Echo "Usage:  " & WScript.ScriptName & " [-s] [SourceFile] [-d] DestinationFile [-e]" & vbCrLf
        WScript.Echo "Examples:" & vbCrLf
        WScript.Echo "   COMMAND                     " & vbTab & "DESCRIPTION"
        WScript.Echo "   " & WScript.ScriptName & " sample.txt" & vbTab & "Compress sample.txt File To Zip"
        WScript.Echo "   " & WScript.ScriptName & " sample.zip" & vbTab & "Decompress Zip To Current Direcotry" & vbCrLf
        WScript.Echo "   " & WScript.ScriptName & " C:\Windows\System32\drivers\etc etc.zip"
        WScript.Echo "   " & WScript.ScriptName & " etc.zip C:\Windows\System32\drivers\etc"
        WScript.Echo "   " & WScript.ScriptName & " C:\Windows\KB*.log;C:\Windows\Notepad.exe C:\sample.zip"
        Exit Function
    End If
    
    Dim strSourceFileOrDir, strTargetFileOrDir, blnInDecompressMode, objFileSystemObject

        
    blnInDecompressMode = False
    Dim strTargetDir
    Set objFileSystemObject = CreateObject("Scripting.FileSystemObject")

    If colArguments.Count = 1 Then
        strSourceFileOrDir = colArguments(0)
        If objFileSystemObject.FileExists(strSourceFileOrDir) And _
            UCase(objFileSystemObject.GetExtensionName(strSourceFileOrDir)) = "ZIP" Then
            blnInDecompressMode = True
            strTargetFileOrDir = objFileSystemObject.GetParentFolderName(colArguments(0))
        ElseIf objFileSystemObject.FileExists(strSourceFileOrDir) Then
            
            strTargetDir = objFileSystemObject.GetParentFolderName(strSourceFileOrDir)
            strTargetFileOrDir = PathAddBackslash(objFileSystemObject, strTargetDir) & _
                                "\" & objFileSystemObject.GetBaseName(colArguments(0)) & ".zip"
        ElseIf objFileSystemObject.FolderExists(strSourceFileOrDir) Then
            strTargetDir = objFileSystemObject.GetParentFolderName(strSourceFileOrDir)
            strTargetFileOrDir = PathAddBackslash(objFileSystemObject, strTargetDir) & _
                        "\" & objFileSystemObject.GetBaseName(colArguments(0)) & ".zip"
        Else
            WSH.Echo "ERROR: File or Directory does not exists."
            Exit Function
        End If
    ElseIf colArguments.Count = 2 Then
        strSourceFileOrDir = colArguments(0)
        strTargetFileOrDir = colArguments(1)
        If objFileSystemObject.FileExists(strSourceFileOrDir) And _
            UCase(objFileSystemObject.GetExtensionName(strSourceFileOrDir)) = "ZIP"  Then
            blnInDecompressMode = True
            If Not objFileSystemObject.FolderExists(strTargetFileOrDir) Then
                WSH.Echo "ERROR: Target Directory does not exists."
                Exit Function
            End If
        ElseIf objFileSystemObject.FileExists(strSourceFileOrDir) Or _
            objFileSystemObject.FolderExists(strSourceFileOrDir) Then
            If objFileSystemObject.FolderExists(strTargetFileOrDir) Then
                strTargetFileOrDir = PathAddBackslash(objFileSystemObject, strTargetFileOrDir) & _
                            objFileSystemObject.GetBaseName(strSourceFileOrDir) & ".zip"
            Else

            End If
        Else
            WSH.Echo "ERROR: Source File does not exists."
            Exit Function
        End If
        

    End If

    
    strSourceFileOrDir = objFileSystemObject.GetAbsolutePathName(strSourceFileOrDir)
    strTargetFileOrDir = objFileSystemObject.GetAbsolutePathName(strTargetFileOrDir)
    Set objFileSystemObject = Nothing
    
    Dim zip
    Set zip = New ZipCompressor
        If blnInDecompressMode Then
            WSH.Echo "Decompressing..."
            ShowStatus strSourceFileOrDir, strTargetFileOrDir
            zip.decompress strSourceFileOrDir, strTargetFileOrDir
        Else
            WSH.Echo "Compressing..."
            ShowStatus strSourceFileOrDir, strTargetFileOrDir
            zip.compress strSourceFileOrDir, strTargetFileOrDir
        End If
    Set zip = Nothing
    WSH.Echo "Completed."
    'WScript.StdIn.Read(1)
End Function

Sub ShowStatus(ByVal strSourceFileOrDir, ByVal strTargetFileOrDir)
    Dim objFileSystemObject
    Dim nMaxLineLength, nSFLength, nTFLength
    Dim strSF, strTF
    Set objFileSystemObject = CreateObject("Scripting.FileSystemObject")
    strSF = objFileSystemObject.GetBaseName(strSourceFileOrDir) & "." & _
                        objFileSystemObject.GetExtensionName(strSourceFileOrDir)
    strTF = objFileSystemObject.GetBaseName(strTargetFileOrDir) & "." & _
                        objFileSystemObject.GetExtensionName(strTargetFileOrDir)
    nSFLength = CInt(LenB(strSF) / 2)
    nTFLength = Cint(LenB(strTF) / 2)
    If nSFLength > nTFLength Then
        nMaxLineLength = nSFLength
    Else
        nMaxLineLength = nTFLength
    End If

    WSH.Echo "+--------+" & String(nMaxLineLength+2, "-") & "+"
    WSH.Echo "| SOURCE | " & strSF & String(nMaxLineLength-nSFLength, " ") & " |"
    WSH.Echo "+--------+" & String(nMaxLineLength+2, "-") & "+"
    WSH.Echo "| TARGET | " & strTF & String(nMaxLineLength-nTFLength, " ") & " |"
    WSH.Echo "+--------+" & String(nMaxLineLength+2, "-") & "+"
    Set objFileSystemObject = Nothing
End Sub

Call WScript.Quit(VBMain(WScript.Arguments)) ' Call Function VBMain immeidately