Macro to Zip XLSM workbooks in Folder and Sub-Folders

howard

Well-known Member
Joined
Jun 26, 2006
Messages
5,669
Office Version
  1. 2019
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
 

Some videos you may like

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
2,588
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
 

howard

Well-known Member
Joined
Jun 26, 2006
Messages
5,669
Office Version
  1. 2019
Platform
  1. Windows
Thanks for the help. Where do I insert the code ?
 

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
2,588
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
 

howard

Well-known Member
Joined
Jun 26, 2006
Messages
5,669
Office Version
  1. 2019
Platform
  1. Windows

ADVERTISEMENT

Thanks for your help Dave
 

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
2,588
You are welcome. Thanks for posting your outcome. Dave
whoops... this line should be...
Code:
Do Until oApp.Namespace(Filename).Items.Count = 1
 

howard

Well-known Member
Joined
Jun 26, 2006
Messages
5,669
Office Version
  1. 2019
Platform
  1. Windows
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

Well-known Member
Joined
Nov 9, 2002
Messages
2,588
Again, you are welcome and my apologies for not catching my error before I initially posted my response. Dave
 

Watch MrExcel Video

Forum statistics

Threads
1,114,665
Messages
5,549,307
Members
410,909
Latest member
aa42
Top