Macro to Zip XLSM workbooks in Folder and Sub-Folders

[howard]

I have a macro to zip xlsm workbooks in C:\Sales directory as well as sub-folders

The macro zips the files but A get a zip error message-see link below

Dropbox

www.dropbox.com

It would be appreciated if someone could amend my code to prevent this error

 Dim x As Integer
Dim fso As Object
Dim result As Boolean

Sub SubFolderInfo()
Application.ScreenUpdating = False
'------------------------------------
'DECLARE AND SET VARIABLES
Dim strPath As String
strPath = "C:\sales\"
x = 0
Set fso = CreateObject("Scripting.FileSystemObject")
'------------------------------------
'CHECK FOLDERS AND SUBFOLDERS

  result = ExtractFileInfo(strPath)
'------------------------------------
'CLEANUP
Set fso = Nothing
MsgBox x & " files have been zipped."
Application.ScreenUpdating = True
End Sub

Private Function ExtractFileInfo(fspec)
On Error GoTo ErrHandler
'------------------------------------
'DECLARE AND SET VARIABLES
Dim fldr As Object, fi As Object, sfldr As Object, oApp As Object
Dim Filename, fname As String
Set fldr = fso.GetFolder(fspec)
'------------------------------------
'CHECK FILES IN TOP FOLDER
If fldr.Files.Count <> 0 Then
For Each fi In fldr.Files
s = Split(fi, ".")

If InStr(1, fi, "(P).xls", 1) > 0 Then
'And UCase(Left(s(1), 2)) = "XL" Then
s = Split(fi, ".")
Filename = s(0) & ".zip"
NewZip (Filename)
fname = fi
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(Filename).CopyHere s(0) & "." & s(1) 'FName(iCtr)
x = x + 1
End If
accessnotallowed:
Next
End If
'------------------------------------
'CHECK SUBFOLDERS
If fldr.SubFolders.Count > 0 Then
For Each sfldr In fldr.SubFolders
ExtractFileInfo (sfldr) 'RECURSIVE CHECK
Next
End If
'------------------------------------
'CLEANUP
permissiondenied:
ExtractFileInfo = True
Set fldr = Nothing
ExitHandler:
Application.ScreenUpdating = True
Exit Function
'------------------------------------
'HANDLE RETURNED ERROR
ErrHandler:
If Err.Number = 70 Then 'permission denied
Err.Clear
MsgBox fspec & Chr(13) & "Permission Denied"
Resume permissiondenied
Else
MsgBox Err.Number & ": " & Err.Description
Resume ExitHandler
End If
End Function

Sub NewZip(sPath)
'Create empty Zip File
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

 

[NdNoviceHlp]

Hi Howard. U seem to be missing this part of the zip code. HTH. Dave

Set oApp = CreateObject("Shell.Application")
oApp.Namespace(Filename).CopyHere s(0) & "." & s(1) 'FName(iCtr)
On Error Resume Next
Do Until oApp.Namespace(ZipName).Items.Count = 1
Application.Wait (Now + TimeValue("0:00:01"))
Loop
If Err.Number <> 0 Then
MsgBox "Error" & Err.Number & "  " & Err.Description
End If
On Error GoTo 0
Set oApp = Nothing

 

[howard]

Thanks for the help. Where do I insert the code ?

 

[NdNoviceHlp]

howard, U already have this part of the code....

Set oApp = CreateObject("Shell.Application")
oApp.Namespace(Filename).CopyHere s(0) & "." & s(1) 'FName(iCtr)

place the remaining lines below that. You also have an error handler already so U could change this line of code...

If Err.Number <> 0 Then
goto ErrHandler
End If

HTH. Dave

 

[howard]

Thanks for your help Dave

 

[NdNoviceHlp]

You are welcome. Thanks for posting your outcome. Dave
whoops... this line should be...

Do Until oApp.Namespace(Filename).Items.Count = 1

 

[howard]

Thanks Dave. When running the macro before, it took forever to run. I left it and was going to let you know today but you beat me to it

Many thanks for the help

 

[NdNoviceHlp]

Again, you are welcome and my apologies for not catching my error before I initially posted my response. Dave