Macro to Zip XLSM workbooks in Folder and Sub-Folders

howard

Well-known Member
Joined
Jun 26, 2006
Messages
6,561
Office Version
  1. 2021
Platform
  1. Windows
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


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

Code:
 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
 

Excel Facts

Why does 9 mean SUM in SUBTOTAL?
It is because Sum is the 9th alphabetically in Average, Count, CountA, Max, Min, Product, StDev.S, StDev.P, Sum, VAR.S, VAR.P.
Hi Howard. U seem to be missing this part of the zip code. HTH. Dave
Code:
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
 
Upvote 0
Thanks for the help. Where do I insert the code ?
 
Upvote 0
howard, U already have this part of the code....
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...
Code:
If Err.Number <> 0 Then
goto ErrHandler
End If
HTH. Dave
 
Upvote 0
You are welcome. Thanks for posting your outcome. Dave
whoops... this line should be...
Code:
Do Until oApp.Namespace(Filename).Items.Count = 1
 
Upvote 0
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
 
Upvote 0
Again, you are welcome and my apologies for not catching my error before I initially posted my response. Dave
 
Upvote 0

Forum statistics

Threads
1,213,535
Messages
6,114,194
Members
448,554
Latest member
Gleisner2

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