Macro to zip files in folder and sub-folder

Topic

New Reply

I would like to zip all .xls workbooks in folder C:test1 and in the sub-folders of test1 containing the text (P) in the name of the workbook eg BR1_Accnts (P).xls, PE_Accnts (P).xls etc are to be zipped

I have code to do this which I have tried to adapt, but get a compile error: syntax error

I do not want to have to select the files to zip as I have several subfolders within C:test1. All the workbooks in this folder and sub-folder containing (P) in the text for eg BR1_Accnts (P).xls, PE_Accnts (P).xls etc are to be zipped

I have both WinRAR and 7-zip installed on my Laptop

It would be appreciated if someone would kindly help me to resolve this

I have also posted on Ozgrid.com

http://www.ozgrid.com/forum/showthread/?t=195963

Reply | Quote

Replies

Hi
Is this line correct?
————-
Dim aFileTS as Array(zFolder.Count)
—————–

Does it help as
————-
Dim aFileTS(zFolder.Count)
————–

Geof

Reply | Quote

Thanks for the reply

I don’t see Dim aFileTS as Array(zFolder.Count) in my code

Reply | Quote

Dohl .. my bad.
Wrong thread:mad:
G

Reply | Quote

No Problem-it happens to all of us

Reply | Quote

Howard,

You are getting a compile error because it is looking for two functions that do not exist: NewZip() and bIsBookOpen(). Also, your code to get your files should be amended to:

Code:

FName = Application.GetOpenFilename(“Excel Files (*.xl*), *.xl*”, _
    MultiSelect:=True, Title:=”Select the files you want to zip”)

Could you please post the entire sample code from your source?

Just wondering why you cross-post in another forum. Do your queries not get sufficiently answered here in WS?

Maud

Reply | Quote

Hi Maud

Thanks for your reply

This Website is fantastic and I get a very high success rate regarding replies. In future I will wait for a week, before cross-posting.

See My Full Code Below

The code allows me to select the folder to zip the files

I would like to be able to zip all workbooks in C:test1 as well as the sub-folder containing (P) in the text for eg BR1_Accnts (P).xls, PE_Accnts (P).xls etc

It would be appreciated if you would please amend the code accordingly

Code:

 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
    Dim Wkbk
    Dim x As Integer, y As Integer
     
    DefPath = "C:Test1"
     
     
     
   FName = Application.GetOpenFilename("Excel Files (*(P).xl*), *(P).xl*", _
    MultiSelect:=True, Title:="Select the files you want to zip")
    If IsArray(FName) = False Then
         'do nothing
    Else
         
         'Create empty Zip File
         'Wkbk = Split(FName)
         ' NewZip (FileNameZip)
        Set oApp = CreateObject("Shell.Application")
        i = 0
        For iCtr = LBound(FName) To UBound(FName)
            vArr = Split97(FName(iCtr), "")
            sFName = vArr(UBound(vArr))
            x = InStr(sFName, ".")
            y = Len(sFName)
            Wkbk = Left(sFName, y - (y - x) - 1)
            FileNameZip = DefPath & Wkbk & ".zip"
            NewZip (FileNameZip)
            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

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 

Reply | Quote

Howard,

Here is your revised file. I used only the NewZip function provided by Ron de Bruin and rewrote the rest using some code I modified from some source obtained somewhere in the past. The code will check the C:Test1 folder and its subfolders for Excel files containing “(P)”. If found, it will create a zipped file with the same name. A message box will indicate how many zipped files were created.

HTH,
Maud

Code:

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

Sub SubFolderInfo()
Application.ScreenUpdating = False
[COLOR=”#008000″]’————————————
‘DECLARE AND SET VARIABLES[/COLOR]
    Dim strPath As String
    strPath = “C:Test1”
    x = 0
    Set fso = CreateObject(“Scripting.FileSystemObject”)
[COLOR=”#008000″]’————————————
‘CHECK FOLDERS AND SUBFOLDERS[/COLOR]
    result = ExtractFileInfo(strPath)
[COLOR=”#008000″]’————————————
‘CLEANUP[/COLOR]
    Set fso = Nothing
    MsgBox x & ” files have been zipped.”
Application.ScreenUpdating = True
End Sub


Private Function ExtractFileInfo(fspec)
    On Error GoTo ErrHandler
[COLOR=”#008000″]’————————————
‘DECLARE AND SET VARIABLES[/COLOR]
    Dim fldr As Object, fi As Object, sfldr As Object, oApp As Object
    Dim Filename, fname As String
    Set fldr = fso.GetFolder(fspec)
[COLOR=”#008000″]’————————————
‘CHECK FILES IN TOP FOLDER[/COLOR]
    If fldr.Files.Count  0 Then
        For Each fi In fldr.Files
            s = Split(fi, “.”)
            If InStr(1, fi, “(P)”, 1) > 0 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
[COLOR=”#008000″]’————————————
‘CHECK SUBFOLDERS[/COLOR]
    If fldr.SubFolders.Count > 0 Then
        For Each sfldr In fldr.SubFolders
            ExtractFileInfo (sfldr) ‘RECURSIVE CHECK
        Next
    End If
[COLOR=”#008000″]’————————————
‘CLEANUP[/COLOR]
permissiondenied:
    ExtractFileInfo = True
    Set fldr = Nothing
ExitHandler:
    Application.ScreenUpdating = True
    Exit Function
[COLOR=”#008000″]’————————————
‘HANDLE RETURNED ERROR[/COLOR]
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)
[COLOR=”#008000″]’Create empty Zip File
‘Changed by keepITcool Dec-12-2005[/COLOR]
    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

Reply | Quote

Howard,

Here is your revised file. I used only the NewZip function provided by Ron de Bruin and rewrote the rest using some code I modified from some source obtained somewhere in the past. The code will check the C:Test1 folder and its subfolders for Excel files containing “(P)”. If found, it will create a zipped file with the same name. A message box will indicate how many zipped files were created.

HTH,
Maud

Code:

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

Sub SubFolderInfo()
Application.ScreenUpdating = False
[COLOR=#008000]’————————————
‘DECLARE AND SET VARIABLES[/COLOR]
    Dim strPath As String
    strPath = “C:Test1”
    x = 0
    Set fso = CreateObject(“Scripting.FileSystemObject”)
[COLOR=#008000]’————————————
‘CHECK FOLDERS AND SUBFOLDERS[/COLOR]
    result = ExtractFileInfo(strPath)
[COLOR=#008000]’————————————
‘CLEANUP[/COLOR]
    Set fso = Nothing
    MsgBox x & ” files have been zipped.”
Application.ScreenUpdating = True
End Sub


Private Function ExtractFileInfo(fspec)
    On Error GoTo ErrHandler
[COLOR=#008000]’————————————
‘DECLARE AND SET VARIABLES[/COLOR]
    Dim fldr As Object, fi As Object, sfldr As Object, oApp As Object
    Dim Filename, fname As String
    Set fldr = fso.GetFolder(fspec)
[COLOR=#008000]’————————————
‘CHECK FILES IN TOP FOLDER[/COLOR]
    If fldr.Files.Count  0 Then
        For Each fi In fldr.Files
            s = Split(fi, “.”)
            If InStr(1, fi, “(P)”, 1) > 0 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
[COLOR=#008000]’————————————
‘CHECK SUBFOLDERS[/COLOR]
    If fldr.SubFolders.Count > 0 Then
        For Each sfldr In fldr.SubFolders
            ExtractFileInfo (sfldr) ‘RECURSIVE CHECK
        Next
    End If
[COLOR=#008000]’————————————
‘CLEANUP[/COLOR]
permissiondenied:
    ExtractFileInfo = True
    Set fldr = Nothing
ExitHandler:
    Application.ScreenUpdating = True
    Exit Function
[COLOR=#008000]’————————————
‘HANDLE RETURNED ERROR[/COLOR]
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)
[COLOR=#008000]’Create empty Zip File
‘Changed by keepITcool Dec-12-2005[/COLOR]
    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

How do you amend it to zip all files in a selected folder?

Reply | Quote

Hi Maud

Thanks very much. Code works perfectly

Howard

Reply | Quote

See your new topic.
/showthread//183128-how-to-use-vba-variables-in-powershell-script-while-running-it-from-VBA

cheers, Paul

Reply | Quote

Hi gvfos,

Please see the code by Ron DeBruin that was modified. The code will allow you to navigate to the desired folder and zip all the files within that folder to a ZIP file with the same name located located in the same parent directory as the folder.

Code:

Sub Zip_All_Files_in_Folder_Browse()
'=============================================
'ZIP A FOLDER INTO THE SAME PARENT DIRECTORY AS THE FOLDER
'CODE BY RON DEBRUIN MODIFIED BY MAUDIBE
'=============================================
'DECLARE AND SET VARIABLES
    Dim FileNameZip, FolderName, oFolder
    Dim oApp As Object
    Set oApp = CreateObject("Shell.Application")
'---------------------------------------------
'BROWSE TO THE DESIRED FOLDER
    Set oFolder = oApp.BrowseForFolder(0, "Select folder to Zip", 512)
'---------------------------------------------
'GET PATH OF SELECTED AND SELECTED PARENT FOLDERS AND CREATE ZIP FILE
    FolderName = oFolder.self.Path & ""
    FileNameZip = oFolder.self.Parent.self.Path & "" & oFolder & ".zip"
    NewZip (FileNameZip)
'---------------------------------------------
'COPY FILES TO ZIP FILE
    If Not oFolder Is Nothing Then
        oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).items
'---------------------------------------------
'KEEP SCRIPT WAITING UNTIL COMPRESSING COMPLETED
        On Error Resume Next
            Do Until oApp.Namespace(FileNameZip).items.Count = oApp.Namespace(FolderName).items.Count
                Application.Wait (Now + TimeValue("0:00:01"))
            Loop
        On Error GoTo 0
    End If
'---------------------------------------------
'CLEANUP
    Set oApp = Nothing
    Set oFolder = Nothing
End Sub

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

HTH,
Maud

Reply | Quote