Macro to Zip XLSM workbooks in Folder and Sub-Folders

howard

Well-known Member
Joined
Jun 26, 2006
Messages
5,660
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

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
2,565
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,660
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,565
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,660
Office Version
  1. 2019
Platform
  1. Windows

ADVERTISEMENT

Thanks for your help Dave
 

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
2,565
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,660
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,565
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,113,824
Messages
5,544,539
Members
410,619
Latest member
gregor222
Top