Attribute VB_Name = "basZip"
Option Explicit

Public Function CompressFileArrayXP(arrFiles, MyZipName, MyZipPath, intFileCount As Integer) As Boolean
    'this function uses Windows XP's built-in compression utility to zip all files named in an array
    'arrFiles = array containing full names (incl paths) of files to be zipped together
    'NB - arrFiles must have 1 as the index of its first value (NOT zero)
    'MyZipName = name of zip file to be created (without .zip extension)
    'MyZipPath = path of folder where zip file is to be created e.g. "C:\"
    'intFileCount is the number of files being zipped

    On Error GoTo err_Handler

    Dim MyTarget, MyHex, MyBinary, i
    Dim oShell, oApp, oFolder, oFileSys, oCTF

    'This is the HEX that makes up the 22 Bytes that is an Empty .Zip File
    MyHex = Array(80, 75, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
    For i = 0 To UBound(MyHex)
        MyBinary = MyBinary & Chr(MyHex(i))
    Next

    Set oShell = CreateObject("WScript.Shell") 'Create As Object
    MyTarget = MyZipPath & MyZipName & ".zip"
    
    'check if a file already exists with the target name; if so, delete it
    If FileOrDirExists(CStr(MyTarget)) Then
        Kill (MyTarget)
    End If

    'Then we make the Empty .Zip File
    Set oFileSys = CreateObject("Scripting.FileSystemObject")
    Set oCTF = oFileSys.CreateTextFile(MyTarget, True)
        oCTF.Write MyBinary
        oCTF.Close
    Set oCTF = Nothing
    
    'Copy the files into the .ZIP with a progress bar
    Set oApp = CreateObject("Shell.Application")
    
    For i = 1 To UBound(arrFiles)
        If FileOrDirExists(CStr(arrFiles(i))) Then
            oApp.Namespace(MyTarget).CopyHere CVar(arrFiles(i))  'Copy the files that are in the source folder
        End If
    Next i
        
    'Keep script waiting until Compressing is done
    On Error Resume Next
    Do Until oApp.Namespace(MyTarget).Items.Count = intFileCount
        'Debug.Print oApp.Namespace(MyTarget).Items.count
        Application.Wait (Now + TimeValue("0:00:01"))
    Loop
    
    'Tidy Up
    Set oApp = Nothing
    Set oFolder = Nothing
    Set oShell = Nothing
    
    Set oFileSys = Nothing
    
    CompressFileArrayXP = True
    
    Exit Function

err_Handler:
    
    CompressFileArrayXP = False
    
    'Tidy Up
    Set oApp = Nothing
    Set oFolder = Nothing
    Set oShell = Nothing
    
    Set oFileSys = Nothing

End Function

Public Function WinZipFileArray(arrFiles, FileNameZip, MyZipPath, PathWinZip) As Boolean
    'this function calls WinZip to zip all files named in an array
    'arrFiles = array containing full names (incl paths) of files to be zipped together
    'NB - arrFiles must have 1 as the index of its first value (NOT zero)
    'FileNameZip = name of zip file to be created (without .zip extension)
    'MyZipPath = path of folder where zip file is to be created e.g. "C:\"

On Error GoTo err_Handler

    WinZipFileArray = False

    Dim namelist As String
    Dim ShellStr As String, sFileNameXls As String
    Dim vArr As Variant, iCtr As Long
    Dim i As Integer
         
    PathWinZip = GetPathName(CStr(PathWinZip))    'get just the file path
    FileNameZip = MyZipPath & FileNameZip & ".zip"
    
    If IsArray(arrFiles) = False Then
        'do nothing
    ElseIf UBound(arrFiles) < intWinZipFileLimit Then       'with too many files passed for compression, WinZip will crap out
        namelist = ""
        For iCtr = 1 To UBound(arrFiles)
            
            If FileOrDirExists(CStr(arrFiles(iCtr))) Then
                namelist = namelist & " " & Chr(34) & arrFiles(iCtr) & Chr(34)
            End If
        
        Next iCtr


        ShellStr = PathWinZip & "Winzip32 -min -a " _
                 & " " & Chr(34) & FileNameZip & Chr(34) _
                 & " " & namelist
        ShellAndWait ShellStr, vbHide
        
        WinZipFileArray = True
    Else                                            'WinZip files in smaller batches
        i = intWinZipFileLimit
        iCtr = 1
        Do While iCtr <= UBound(arrFiles)
            namelist = ""
            For iCtr = iCtr To i
                If iCtr <= UBound(arrFiles) Then
                    If FileOrDirExists(CStr(arrFiles(iCtr))) Then
                        namelist = namelist & " " & Chr(34) & arrFiles(iCtr) & Chr(34)
                    End If
                Else
                    'do nothing
                End If
            Next iCtr
            ShellStr = PathWinZip & "Winzip32 -min -a " _
                & " " & Chr(34) & FileNameZip & Chr(34) _
                & " " & namelist
            ShellAndWait ShellStr, vbHide
            i = i + intWinZipFileLimit
        Loop
        
        WinZipFileArray = True
    
    End If
    
    Exit Function
    
err_Handler:

    WinZipFileArray = False

End Function

Function FileOrDirExists(PathName As String) As Boolean
     'Purpose      : Function returns TRUE if the specified file
     '               or folder exists, false if not.
     'PathName     : Supports Windows mapped drives or UNC
     '             : Supports Macintosh paths
     'File usage   : Provide full file path and extension
     'Folder usage : Provide full folder path
     '               Accepts with/without trailing "\" (Windows)
     '               Accepts with/without trailing ":" (Macintosh)
     
    Dim iTemp As Integer
     
     'Ignore errors to allow for error evaluation
    On Error Resume Next
    iTemp = GetAttr(PathName)
     
     'Check if error exists and set response appropriately
    Select Case Err.Number
    Case Is = 0
        FileOrDirExists = True
    Case Else
        FileOrDirExists = False
    End Select
     
     'Resume error checking
    On Error GoTo 0
End Function