Zip Files

[rudevincy]

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

 

[LockeGarmin]

Try including the full file path, not just the file names.

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

 

[NdNoviceHlp]

Here's some zip stuff that might help. Dave
Solved: Unzip Problem using Ron de Bruin's code
edit: Whoops that's unzip. It can be adjusted to zip. I may have another link...
edit2: HTH. http://www.vbaexpress.com/forum/showthread.php?17357-Using-Namespace-and-Objects

 

[rudevincy]

Thank you sooooooo much LockeGarmin this worked..

 

[rudevincy]

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)