How to zip the a folder based on a date range

[zeee91]

Hello,

Im attempting to zip files based on a date range. I want a pop up to record the date range and zip accodingly. Here is the code i've written in vba for access. I would love your help. Thanks.



Sub CreateZipFile(sPath As Variant, zipName As Variant)

Dim ShellApp As Object

Dim MyObj As Object, MySource As Object, file As Variant



sDate = Year(Now()) & "-" & Month(Now()) & "-" & Day(Now())

sPath = DLookup("FilePathName", "tblProperties", "[ID] = 1")

sFile = .Fields("CUSTOMER_NAME").Value & "Inv" & .Fields("INVOICE_NUMBER").Value & "_" & .Fields("VENDOR_NAME").Value & "_" & sDate & ".pdf"

cusName = Left([sFile], Find("Inv") - 1)

zipName = cusName & sDate & ".zip"

While (sPath <> "")

If InStr(sPath, "") > 0 Then

'Create an empty zip file

Open zipName For Output As #1

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

Close #1

If cusName = .Fields("CUSTOMER_NAME").Value Then

'Copy the files & folders into the zip file

Set ShellApp = CreateObject("Shell.Application")

ShellApp.Namespace(zipName).CopyHere ShellApp.Namespace(sPath).items

'Zipping files

On Error Resume Next

Do Until ShellApp.Namespace(zippedInvoices).items.Count = ShellApp.Namespace(sPath).items.Count

Application.Wait (Now + TimeValue("0:00:01"))

Loop

On Error GoTo 0

MsgBox "Created zip" & zipName

End If

file = Dir

Wend

End Sub

 

[xenou]

This looks like it has most of the same problems. By the way, how many files do you anticipate archiving, generally? A handful at a time? Dozens? Hundreds?

 

[zeee91]

A handful. Max would be about 30 but no more than that.

 

[zeee91]

Do you think you can help me fix them cuz im stuck? lol

 

[xenou]

This is what I have so far.
Unfortunately it is not working for me because when I create the new zip archive it can't retrieve the reference to it in the next statement:

Set objFolder_Src = ShellApp.Namespace(folder_with_files_to_zip) '//FAIL

This didn't happen last week

The strategy here is composition - use the old version we started with (zip all files in a folder). What we do is just put in line with that another sub that creates the folder of files we need to zip up.

Option Compare Database
Option Explicit
Public Declare PtrSafe Sub sleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As LongPtr)
'For 32 Bit Systems: Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds as Long)

Sub Foo()
Dim FSO As Object
    
    On Error Resume Next
    CreateObject("Scripting.FileSystemObject").DeleteFolder "C:\myTemp\NewZipArchive.zip"
    On Error GoTo 0
    
    Call CreateZipFileFiltered("C:\MyTemp\Test3", "201703", "C:\myTemp\NewZipArchive.zip")

End Sub

Sub CreateZipFileFiltered(folder_with_col As String, file_name_filter_text As String, new_zip_folder_name As String)
    
    Dim FSO As Scripting.FileSystemObject
    Dim f As Scripting.file
    Dim temp_folder As Scripting.Folder
    Dim col As VBA.Collection
    Dim temp_folder_path As String
    Dim vKey
    Dim i As Long
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set col = New VBA.Collection
    Dim dummy
    
    '//Collect files that need to be zipped with filtering on filename
    For Each f In FSO.GetFolder(folder_with_col).Files
        If f.Name Like "*" & file_name_filter_text & "*" Then
            i = i + 1
            col.Add f.Path, CStr(i)
        End If
    Next f
    
    '//Copy files to folder for zipping
    If col.Count > 1 Then
        temp_folder_path = FSO.GetSpecialFolder(2).Path
        temp_folder_path = temp_folder_path + "\" + FSO.GetTempName
        Set temp_folder = FSO.CreateFolder(Replace(temp_folder_path, ".tmp", ""))
        For Each vKey In col
            dummy = temp_folder.Path + "\" + FSO.GetFileName(vKey)
            Call FSO.CopyFile(vKey, temp_folder.Path + "\" + FSO.GetFileName(vKey))
        Next vKey
    End If
    
    '//Zip up the files
    Call CreateZipFile(temp_folder.Path, new_zip_folder_name)
    
    '//cleanup
    Call FSO.DeleteFolder(temp_folder.Path, True)

End Sub

Sub CreateZipFile(folder_with_files_to_zip As Variant, new_zip_folder_name As Variant)
Dim ShellApp As Object
Dim item As Object
Dim objFolder_Dest As Object
Dim objFolder_Src As Object
Dim cnt As Long

    'Create an empty zip file
    Open new_zip_folder_name For Output As [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] 
    Print [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] , Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] 
    sleep (200)
    
    Set ShellApp = CreateObject("Shell.Application")
    
    '// Get a reference on the destination folder
    Set objFolder_Src = ShellApp.Namespace(folder_with_files_to_zip)
    sleep 200
    
    '// Get a reference on the source folder
    Set objFolder_Dest = ShellApp.Namespace(new_zip_folder_name)
    sleep 200
    
    'Copy the files & folders into the zip file
    objFolder_Dest.CopyHere objFolder_Src.Items
    Do While objFolder_Dest.Items.Count = objFolder_Src.Items.Count
        sleep (200)
    Loop
    
End Sub

 

[xenou]

I worked up a basic alternative based on powershell on the reasoning that it would be more up to date and flexible (which both turned out to be true):

Option Compare Database
Option Explicit
Public Declare PtrSafe Sub sleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As LongPtr)
'For 32 Bit Systems: Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds as Long)

Sub foo()
Dim FSO As Object
    
    '-------------------------------------------------------------------------------
    'Parameters:
    'SRC - A Folder Path which may contain wildcards
    'DEST - the name of a destination zip archive which WILL BE DELETED IF IT EXISTS
    
    'Result:
    'Creates a zip file of the file(s) indicated

    '[COLOR="#FF0000"]Warning[/COLOR]:
    'As written this script expects no spaces in file paths.
    '-------------------------------------------------------------------------------
    
    
    Dim SRC As String
    Dim DEST As String
    Dim Filter_Text As String
    
    
    SRC = "C:\MyTemp\Test3\*201703*"
    DEST = "C:\MyTemp\NewZipArchive.zip"
        
    On Error Resume Next
    CreateObject("Scripting.FileSystemObject").DeleteFile DEST
    On Error GoTo 0
    
    Call ZipItUp(SRC, DEST)

End Sub


Sub ZipItUp(SRC As String, DEST As String)

    Dim PSCommand As String
    Dim retval As Long
    
    PSCommand = "PowerShell -Command ""Compress-Archive -Path SOURCE_PATH -DestinationPath DESTINATION_PATH"""
    PSCommand = Replace(PSCommand, "SOURCE_PATH", SRC)
    PSCommand = Replace(PSCommand, "DESTINATION_PATH", DEST)
    Debug.Print PSCommand
    retval = Shell(PSCommand, vbMinimizedNoFocus)
    '//Debug.Print retval

    '//Wait a few seconds for files to compress (this is unnecessary if no further code will use these files, otherwise
    '//  we don't want the VBA code to run ahead of this powershell command completing)
    sleep 5000

End Sub

PowerShell Compress-Archive: https://docs.microsoft.com/en-us/po...ll.archive/compress-archive?view=powershell-6
Running Powershell commands with VBA: https://stackoverflow.com/questions/32101010/run-a-powershell-command-not-script-from-excel-vba (but I didn't surround my command with braces although otherwise this example was useful)