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
 

Some videos you may like

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.

xenou

MrExcel MVP, Moderator
Joined
Mar 2, 2007
Messages
16,627
Office Version
2013
Platform
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, Moderator
Joined
Mar 2, 2007
Messages
16,627
Office Version
2013
Platform
Windows
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, Moderator
Joined
Mar 2, 2007
Messages
16,627
Office Version
2013
Platform
Windows
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, Moderator
Joined
Mar 2, 2007
Messages
16,627
Office Version
2013
Platform
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,095,475
Messages
5,444,701
Members
405,298
Latest member
fxtrtr17

This Week's Hot Topics

Top