How to zip the a folder based on a date range

Z

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
 
Sort by date Sort by votes
The question is what are you comparing your dates too?
For instance, if my file is called MyTestFile.txt and the dates are 1/1/19 - 1/31/19 then what determines if MyTestFile.txt is "in" this date range?
 
Upvote 0

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
The naming comvention has the date so i want to filter by that.

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

sFile has sDate in it. so for examle te file name wil be custnameInv26454_vendname_02MAR19.pdf

I want to filter the date part of that string. does that make sense?
 
Upvote 0
Okay. I'well now it's starting to fall apart because the code written is not meant for filtering like this.

You can check each file before you copy it. Probably like this:

Code: 
    'Zipping the files may take a while, create loop to pause the macro until zipping has finished.
    For Each item in  ShellApp.Namespace(folderToZipPath).Items
		If(item.Name) Like "*02MAR2019*" Then
			ShellApp.Namespace(folderToZipPath).CopyHere item
			Sleep (1000)
		End If
    Next item

But it assumes that 1) each item takes less than a second to copy 2) each item takes no more than 1 sec to copy. It also assumes that the time it takes to copy matters (which is assumed because the original author appears to have thought it important to provide some "wait" time for the operation).
 
Last edited:
Upvote 0
Do you think i should increase the wait time?

Will you help me with one more task? The .fields isnt working. i want sFile to pull the columns rm tbl1080. How do i do that? Thank you so much for your help

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

strDate = InputBox("Insert start date in format DD-MON-YY", "Start Date", Format(Now(), "DD-MON-YY"))
endDate = InputBox("Insert end date in format DD-MON-YY", "End Date", Format(Now(), "DD-MON-YY"))
DateRange = "[Date] BETWEEN #" & strDate & "# AND #" & endDate & "#"

If IsDate(strDate) And IsDate(endDate) Then
strDate = Format(CDate(strDate), "DD-MON-YY")
endDate = Format(CDate(strDate), "DD-MON-YY")
MsgBox "Date Range: " & strDate & "-" & endDate

Else
MsgBox "Wrong date format"
End If
End Sub

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


Set rs = CurrentDb.OpenRecordset("SELECT * FROM tbl1080")
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"

Call UserDate(strDate, endDate, DateRange)




If rs.EOF Then

Else
With rsAAEB
.MoveFirst
Do Until .EOF

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 the files may take a while, create loop to pause the macro until zipping has finished.
For Each Item In ShellApp.Namespace(sPath).Items
If (Item.Name) = DateRange Then
ShellApp.Namespace(sPath).CopyHere Item
'Application.Wait (Now + TimeValue("0:00:01"))
Sleep (1000)
End If
Next Item

'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 If
End Sub
 
Upvote 0
A small step forward here (very unsatisfactory because we are shoeing in a required wait period which might be too short (crash!) and probably is too long (slow!). So next step is to implement a method to get the shell to wait until the operation completes before the the code moves to the next line (by default shell does not do this which is why we must add the clunky sleep functions). The first code was better because it only waited at most 1 sec too long.

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()
    
    Dim folderToZipPath As String
    Dim Filter_Text As String
    
    folderToZipPath = "C:\MyTemp\Test3"
    Filter_Text = "Mar19"
    
    Call CreateZipFile("C:\myTemp\Test3", "C:\myTemp\NewZipArchive.zip", "201703")

End Sub

Sub CreateZipFile(folderToZipPath As Variant, zippedFileFullName As Variant, FileName_Filter As String)
Dim ShellApp As Object
Dim item As Object

    'Create an empty zip file
    Open zippedFileFullName 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")
    
    If (FileName_Filter = "") Then
        'Copy the files & folders into the zip file
        ShellApp.Namespace(zippedFileFullName).CopyHere ShellApp.Namespace(folderToZipPath).items
        'Wait until complete
        Do Until ShellApp.Namespace(zippedFileFullName).items.Count = ShellApp.Namespace(folderToZipPath).items.Count
            Sleep (200)
        Loop
    Else
        'Copy the files & folders into the zip file
        For Each item In ShellApp.Namespace(folderToZipPath).items
            If (item.Name) Like "*" & FileName_Filter & "*" Then
                ShellApp.Namespace(zippedFileFullName).CopyHere item
                Sleep (500)
            End If
        Next item
    End If
    
End Sub
 
Upvote 0
Does this look better? Also will you look at the loop at the end? it wont compile. thankyou for helpingme

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

strDate = InputBox("Insert start date in format DD-MON-YYYY", "Start Date", Format(Now(), "DD-MON-YYYY"))
endDate = InputBox("Insert end date in format DD-MON-YYYY", "End Date", Format(Now(), "DD-MON-YYYY"))
DateRange = "[Date] BETWEEN #" & strDate & "# AND #" & endDate & "#"

If IsDate(strDate) And IsDate(endDate) Then
strDate = Format(CDate(strDate), "DD-MON-YYYY")
endDate = Format(CDate(endDate), "DD-MON-YYYY")
MsgBox "Date Range: " & strDate & "-" & endDate

Else
MsgBox "Wrong date format"
End If
End Sub

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
Dim item As Object
Dim sleep As Object
Set rs = CurrentDb.OpenRecordset("SELECT * FROM tbl1080")
If rs.EOF Then

Else
With rs
.MoveFirst
Do Until .EOF

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"

'Call UserDate(strDate, endDate, DateRange)

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
sleep (200)
Set ShellApp = CreateObject("Shell.Application")

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
'Wait until complete
Do Until ShellApp.Namespace(zippedFileFullName).Items.Count = ShellApp.Namespace(folderToZipPath).Items.Count
sleep (200)
Loop
Else
'Zipping the files may take a while, create loop to pause the macro until zipping has finished.
For Each item In ShellApp.Namespace(sPath).Items
If (item.Name) = DateRange Then
ShellApp.Namespace(sPath).CopyHere item
'Application.Wait (Now + TimeValue("0:00:01"))
sleep (500)
End If
Next item

'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
'Loop
End If

End Sub
Sub zip()
Call CreateZipFile(sPath, zipName)
End Sub
 
Upvote 0
I don't think that will work. Too many problems. These all might be issues:
  • Creation of the zip folder looks incorrectly placed or done at the wrong time
  • Not using filename filter (which was the whole point)
  • Access doesn't have a Now() function (Access uses Date())
  • Looks like you are trying to do either all items or some items that meet the criteria (not sure - are you changing requirements again?)
  • Not using the filtering at all
  • I can't tell if the final lines are valid at all - looks like leftover code from earlier revisions
  • No declaration of the sleep function
 
Upvote 0
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 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
Dim item As Object
Dim sleep As Object
Set rs = CurrentDb.OpenRecordset("SELECT * FROM tbl1080")
If rs.EOF Then

Else
With rs
.MoveFirst
Do Until .EOF

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"

'Call UserDate(DateRange)

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
sleep (200)
Set ShellApp = CreateObject("Shell.Application")

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
'Wait until complete
Do Until ShellApp.Namespace(zipName).Items.Count = ShellApp.Namespace(folderToZipPath).Items.Count
sleep (200)
Loop
Else
'Zipping the files may take a while, create loop to pause the macro until zipping has finished.
For Each item In ShellApp.Namespace(sPath).Items
If (item.Name) Like "*" & DateRange & "*" Then
ShellApp.Namespace(sPath).CopyHere item
'Application.Wait (Now + TimeValue("0:00:01"))
sleep (500)
End If
Next item

'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
'Loop
End If

End Sub
 
Upvote 0
apologzies, the requirements didnt change. I think i just missed some parts. Does this look better?
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Solved
Runtime error 91 when adding to Zip file.
Replies
1
Views
771
NdNoviceHlp
NdNoviceHlp
R
  • Question Question
How to catch error during zipping
Replies
4
Views
631
Micron
M
KenCriss
  • Locked
  • Question Question
Zipping a group of files using generic zipping code
Replies
1
Views
984
Fluff
Fluff
KenCriss
  • Question Question
Zipping a group of files using generic zipping code
Replies
4
Views
873
John_w
J
J
  • Question Question
Loop through all files in folder and extract rows with specified date range from input box
Replies
1
Views
439
davesexcel
davesexcel

Forum statistics

Threads
1,223,738
Messages
6,174,213
Members
452,551
Latest member
croud

Share this page

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
Back
Top