How to zip the a folder based on a date range

zeee91

New Member
Joined
Mar 21, 2019
Messages
14
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
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.

xenou

MrExcel MVP
Joined
Mar 2, 2007
Messages
16,832
Office Version
  1. 2019
Platform
  1. Windows
Did you write this code from scratch or did you go from an example? If the latter what example did you use? Also have you tested it yet? I wasn't aware you could create zip files this way so my first question would be simply "Does it work?"
 

zeee91

New Member
Joined
Mar 21, 2019
Messages
14
Thank you so muc for your help. I havent tested it and yes i went off an example. What other way is there to create a zip? Below is the example used.


SubCreateZipFile(folderToZipPath As Variant,zippedFileFullName As Variant)



DimShellApp As Object



'Create an empty zip file

OpenzippedFileFullName 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).CopyHereShellApp.Namespace(folderToZipPath).items



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

On Error Resume Next
Do UntilShellApp.Namespace(zippedFileFullName).items.Count =ShellApp.Namespace(folderToZipPath).items.Count

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

Loop

On Error GoTo 0



EndSub
 

xenou

MrExcel MVP
Joined
Mar 2, 2007
Messages
16,832
Office Version
  1. 2019
Platform
  1. Windows

ADVERTISEMENT

Where did you get that code from, is there a link to the web page? Also if you haven't tested it yet then by all means test it. It might work.
 
Last edited:

zeee91

New Member
Joined
Mar 21, 2019
Messages
14
I don’t have the link but the problem is it won’t compile. I was hoping someone could help.
 

xenou

MrExcel MVP
Joined
Mar 2, 2007
Messages
16,832
Office Version
  1. 2019
Platform
  1. Windows

ADVERTISEMENT

Okay I see.

Here is a rewrite with edits for MSAccess.
The sample code here copies files from folder C:\myTemp\Test3 into a new zip archive created at C:\myTemp\NewZipArchive.zip):

Please note that this is code shown for an entire module, including declarations and methods. This is to show the proper placement of the declaration of the sleep function, which belongs at the top of a public module.

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

Sub TryIt()
    Call CreateZipFile("C:\myTemp\Test3", "C:\myTemp\NewZipArchive.zip")
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
    
    
    'On Error Resume Next
    
    'Zipping the files may take a while, create loop to pause the macro until zipping has finished.
    Do Until ShellApp.Namespace(zippedFileFullName).items.Count = ShellApp.Namespace(folderToZipPath).items.Count
    
        Sleep (1000)
    
    Loop
        
    'On Error GoTo 0


End Sub

Things I did:
  • Some general cleanup of the code syntax because it got a little garbled and some needed spaces went missing
  • MSAccess does not have a Wait() method so substituted a sleep method. You must declare it as shown, at the top of a module, before the subs in the module. When I say module I mean module. I don't think it will work in a form, for instance. Don't take my word for it as I could be wrong.
  • Not sure what the expected errors are and don't think its a good idea to hide them if the code is failing so I commented the error handling pending futher testing (which I myself will probably never do)
 
Last edited:

zeee91

New Member
Joined
Mar 21, 2019
Messages
14
Thank you so much for your help!

I have another question. I want the user to input dates and I want the code to zip between those dates. Does this look right? This part of the code compiled and does as I ask but I’m not sure how to write the filter for the dates. So for example I would want all files with the start and end date to be zipped based on sDate.

Sub UserDate()
Dim strDate As Date, endDate As Date, DateRange As String

strDate = InputBox("Insert start date in format dd/mm/yy", "Start Date", Format(Now(), "dd/mm/yy"))
endDate = InputBox("Insert end date in format dd/mm/yy", "End Date", Format(Now(), "dd/mm/yy"))
DateRange = "[Date] BETWEEN #" & strDate & "# AND #" & endDate & "#"

If IsDate(strDate) And IsDate(endDate) Then
strDate = Format(CDate(strDate), "dd/mm/yy")
endDate = Format(CDate(strDate), "dd/mm/yy")
MsgBox "Date Range: " & strDate & "-" & endDate

Else
MsgBox "Wrong date format"
End If
End Sub
 

xenou

MrExcel MVP
Joined
Mar 2, 2007
Messages
16,832
Office Version
  1. 2019
Platform
  1. Windows
What does it mean for a file to have a start and end date? How would you know whether a file is in the date range you want?
 

zeee91

New Member
Joined
Mar 21, 2019
Messages
14
The oerview is im trying to zip all the files between the strtDate and endDate.

I'm trying to take to values the user enters for strtDate and endDate and return all values between the dates searching on sFile.

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

I think i need to filter sDate but im not sure. What do you think? Im also not sure if y thought pocess is right. lol I then want to zip the files that match the criterea (between strtDate ad endDate). so if sDate falls between strtDate and endDate then zip. Does that help?

Sub CreateZipFile(sPath As Variant, zipName As Variant)

Dim ShellApp As Object
Dim MyObj As Object, MySource As Object, file As Variant
Dim sFile As String, sDate As String
'Call UserDate(strDate, endDate, DateRange)

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], ("Inv") - 1) 'And Where invoice_date= DateRange
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"))
Sleep (1000)
Loop
On Error GoTo 0

MsgBox "Created zip" & zipName

End If
file = Dir
Wend

End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,130,433
Messages
5,642,087
Members
417,256
Latest member
JessAw

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top