Zipping files in a directory, but only X per .zip

[Abraxus]

I have a folder that will have 1 to many .xlsx files in it. I need to zip them up, but have no more than X files in each .zip.
X can be any number, we will start at 20 but maybe go higher.
My thoughts were to copy 20 to another folder, zip them, and delete those copies and repeat as necessary.
My code to do this is here:

Code: Select all

Option Compare Database 

    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub ArchiveFiles()

Debug.Print Now

    Dim intMaxFilesPerZip As Integer

    intMaxFilesPerZip = GetFilesPerZip

    Dim intFileCount As Integer

    intFileCount = 0

    'Copy that many to ToZip folder

    Dim strNow As String

    strNow = Format(Now, "yyyymmdd")

    Dim strFileName As String

    strFileName = Dir(CurrentDBDir & "Output\" & strNow & "\")

    Do While strFileName <> ""

        FileCopy CurrentDBDir & "Output\" & strNow & "\" & strFileName, CurrentDBDir & "Output\ToZip\" & strFileName

        intFileCount = intFileCount + 1

        If intFileCount = intMaxFilesPerZip Then

            'Zip them and start counting again

            CreateZipFile CurrentDBDir & "Output\ToZip\", CurrentDBDir & "Output\Zips\PR_BulkUpload_PS_" & Format(Now, "MMDDYYYYHHmmss") & ".zip"

            Sleep 30000

            intFileCount = 0

            'Delete the files we just zipped

            Kill CurrentDBDir & "Output\ToZip\*.*"

        End If

        strFileName = Dir()

        Beep

    Loop
  

    'Zip the ones left

    CreateZipFile CurrentDBDir & "Output\ToZip\", CurrentDBDir & "Output\Zips\PR_BulkUpload_PS_" & Format(Now, "MMDDYYYYHHmmss") & ".zip"

    Sleep 30000

    'Delete the files we just zipped

    Kill CurrentDBDir & "Output\ToZip\*.*"
       

    'Zip the inputs folder

    CreateZipFile CurrentDBDir & "Inputs\", CurrentDBDir & "Archives\" & Format(Now, "YYYYMMDD") & "_Files.zip"

    Sleep 30000

    Debug.Print Now

    MsgBox "Done!"

End Sub

 
Sub CreateZipFile(folderToZipPath As Variant, zippedFileFullName As Variant)
    Dim ShellApp As Object
    'Create an empty zip file

    Open zippedFileFullName For Output As #1

    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)

    Close #1

    'Copy the files & folders into the zip file

    Set ShellApp = CreateObject("Shell.Application")

    ShellApp.Namespace(zippedFileFullName).CopyHere ShellApp.Namespace(folderToZipPath).items

    'Zipping the files may take a while, create loop to pause the macro until zipping has finished.

    On Error Resume Next

    Do Until ShellApp.Namespace(zippedFileFullName).items.Count = ShellApp.Namespace(folderToZipPath).items.Count

        Sleep 1000

    Loop

    On Error GoTo 0

End Sub

The problem I am running into is that this line:

Code: Select all

strFileName = Dir()

is empty the very first time it gets there, so only one file gets copied.

Suggestions?

Thanks!

[snb]

To insert all files in a certain directory into a zipfile, use lzarccc.exe (free downloadable)
All csv files in J:\Python\GUI into G:\OF\GUI_000.zip

Code: Select all

Sub M_snb()
    Shell "F:\__IZARCcc\izarcc.exe G:\OF\GUI_000.zip J:\Python\GUI\*.csv"
End Sub

[SpeakEasy]

I might be tempted to do a minor rewrite, something like:

Code: Select all

Sub ArchiveFiles()
    Dim strTargetZip As String
    Dim intFileCount As Integer
    Dim intMaxFilesPerZip As Integer
    Dim strNow As String
    Dim strFileName As String
    Dim strSourceDir As String
    
Debug.Print Now

    intMaxFilesPerZip = GetFilesPerZip 'Copy that many to ToZip folder
    intFileCount = 0
    strNow = Format(Now, "yyyymmdd")
    strSourceDir = CurrentDBDir & "Output\" & strNow & "\"
    strFileName = Dir(strSourceDir)

    Do While strFileName <> ""
        If intFileCount Mod intMaxFilesPerZip = 0 Then
            strTargetZip = CurrentDBDir & "Output\Zips\PR_BulkUpload_PS_" & Format(Now, "MMDDYYYYHHmmss") & ".zip"
            CreateZipFile strTargetZip
            Sleep 1500 ' because we are using time with a granularity of 1 sec as unique fileID ...
        End If
        
        With CreateObject("Shell.Application")
            .Namespace("" & strTargetZip).CopyHere strSourceDir & strFileName
        End With
        
        intFileCount = intFileCount + 1
        strFileName = Dir()

        Beep
    Loop

    Debug.Print Now
    MsgBox "Done!"

End Sub

Public Sub CreateZipFile(sPath As String)
    With CreateObject("Scripting.FileSystemObject")
        .CreateTextFile(sPath).Write Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0) ' ZIP header
    End With
End Sub

which removes the need for a temporary marshalling area for the files being zipped.