Results 1 to 8 of 8
  1. #1
    Bronze Lounger
    Join Date
    Feb 2008
    Posts
    1,423
    Thanks
    126
    Thanked 5 Times in 5 Posts

    Macro to zip files in folder and sub-folder

    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.php?t=195963
    Attached Files Attached Files

  2. #2
    Bronze Lounger
    Join Date
    Feb 2008
    Posts
    1,423
    Thanks
    126
    Thanked 5 Times in 5 Posts
    Thanks for the reply

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

  3. #3
    3 Star Lounger
    Join Date
    Apr 2001
    Location
    Levin, Manawatu-Wanganui, New Zealand
    Posts
    324
    Thanks
    9
    Thanked 28 Times in 26 Posts
    Dohl .. my bad.
    Wrong thread
    G

  4. #4
    Bronze Lounger
    Join Date
    Feb 2008
    Posts
    1,423
    Thanks
    126
    Thanked 5 Times in 5 Posts
    No Problem-it happens to all of us

  5. #5
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,640
    Thanks
    115
    Thanked 652 Times in 594 Posts
    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
    Last edited by Maudibe; 2015-07-26 at 01:49. Reason: spelling

  6. #6
    Bronze Lounger
    Join Date
    Feb 2008
    Posts
    1,423
    Thanks
    126
    Thanked 5 Times in 5 Posts
    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

  7. #7
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,640
    Thanks
    115
    Thanked 652 Times in 594 Posts
    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
    '------------------------------------
    'DECLARE AND SET VARIABLES
        Dim strPath As String
        strPath = "C:\Test1\"
        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)", 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
    '------------------------------------
    '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
    '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
    Attached Files Attached Files

  8. The Following User Says Thank You to Maudibe For This Useful Post:

    HowardC (2015-07-26)

  9. #8
    Bronze Lounger
    Join Date
    Feb 2008
    Posts
    1,423
    Thanks
    126
    Thanked 5 Times in 5 Posts
    Hi Maud

    Thanks very much. Code works perfectly


    Howard

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •