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]

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]

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

 

[zeee91]

Sorry for the late response as well

 

[xenou]

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.

 

[zeee91]

I don’t have the link but the problem is it won’t compile. I was hoping someone could help.

 

[xenou]

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.

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)

 

[zeee91]

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]

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]

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