makezip.vbs

Option Explicit

'
' 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


' Put 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