Zip Files

rudevincy

Active Member
Joined
Feb 21, 2005
Messages
415
I am trying to create a zip file for a few excel files. I want to tell the program the files to zip in the vba.... I found a code from Ron de Bruin and in looking online I tried to remove the FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
MultiSelect:=True, Title:="Select the files you want to zip")

and replace it with

FName = Array("61028_201601.xls", "11001_201601.xls", "21029_201601.xls", "31003_201601.xls", "32020_201601.xls", "41001_201601.xls", "42074_201601.xls", "51012_201601.xls")

But it is not working it creates the zip folder but there is nothing in it..... if I use the application where I select the files the program works....

I am banging my head against my desk I just cant seem to get it working.... please please someone help...

Here is the code I got from Ron de Bruin:

Sub NewZip(sPath)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
If Len(Dir(sPath)) > 0 Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub


Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Rob Bovey
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function


Function Split97(sStr As Variant, sdelim As String) As Variant
'Tom Ogilvy
Split97 = Evaluate("{""" & _
Application.Substitute(sStr, sdelim, """,""") & """}")
End Function


Sub Zip_File_Or_Files()
Dim strDate As String, DefPath As String, sFName As String
Dim oApp As Object, iCtr As Long, I As Integer
Dim FName, vArr, FileNameZip

DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If

strDate = Format(Now, " dd-mmm-yy h-mm-ss")
FileNameZip = DefPath & "MyFilesZip " & strDate & ".zip"

'Browse to the file(s), use the Ctrl key to select more files
FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
MultiSelect:=True, Title:="Select the files you want to zip")
If IsArray(FName) = False Then
'do nothing
Else
'Create empty Zip File
NewZip (FileNameZip)
Set oApp = CreateObject("Shell.Application")
I = 0
For iCtr = LBound(FName) To UBound(FName)
vArr = Split97(FName(iCtr), "\")
sFName = vArr(UBound(vArr))
If bIsBookOpen(sFName) Then
MsgBox "You can't zip a file that is open!" & vbLf & _
"Please close it and try again: " & FName(iCtr)
Else
'Copy the file to the compressed folder
I = I + 1
oApp.Namespace(FileNameZip).CopyHere FName(iCtr)

'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).items.Count = I
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
End If
Next iCtr

MsgBox "You find the zipfile here: " & FileNameZip
End If
End Sub
 

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.

LockeGarmin

Active Member
Joined
Sep 11, 2015
Messages
350
Try including the full file path, not just the file names.

Code:
[COLOR=#333333]FName = Array("C:\Excel\61028_201601.xls", "C:\Users\Shekira\My Documents\11001_201601.xls", ...)[/COLOR]
 
Last edited:

rudevincy

Active Member
Joined
Feb 21, 2005
Messages
415
one more thing is I wanted the file path to be the value of what is in a cell can I replace

FName = Array("C:\Excel\61028_201601.xls", "C:\Users\Shekira\My Documents\11001_201601.xls", ...)

with

strFiles = Worksheets("ServiceZip").Range("J1").Value
FName = Array(strFiles)
 

Watch MrExcel Video

Forum statistics

Threads
1,130,201
Messages
5,640,809
Members
417,168
Latest member
StumpoC

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