Excel VBA extract a specific file from zip

Question

I have this code that let's the user select multiple zip files and it will copy all files containing the word "unformatted" in it's name and put it in a folder selected by the user. I don't understand why it doesn't copy to the folder.

thank you for your help

Option Explicit

Sub ExtractUnformattedFilesFromZips()
    'Ask user to select one or more zip files to extract from
    Dim ZipFiles As Variant
    ZipFiles = Application.GetOpenFilename(FileFilter:="Zip Files (*.zip), *.zip", Title:="Select one or more zip files to extract from", MultiSelect:=True)
    
    'Ask user to select output folder where "Unformatted" folder will be created
    Dim OutputFolder As String
    With Application.fileDialog(msoFileDialogFolderPicker)
        .Title = "Select output folder where Unformatted folder will be created"
        .Show
        If .SelectedItems.Count = 1 Then
            OutputFolder = .SelectedItems(1)
        Else
            Exit Sub 'User cancelled or selected more than one folder
        End If
    End With
    
    'Create Unformatted folder in the output folder
    On Error Resume Next 'Avoid error if Unformatted folder already exists
    MkDir OutputFolder & "\Unformatted"
    On Error GoTo 0
    
    'Loop through each selected zip file and extract files with "unformatted" in the name to the Unformatted folder
    Dim ZipFilePath As Variant
    Dim UnformattedFolderPath As String
    UnformattedFolderPath = OutputFolder & "\Unformatted\"
    Dim FileInZip As Variant
    Dim ExtractPath As String
    For Each ZipFilePath In ZipFiles
        If ZipFilePath <> False Then 'User didn't cancel selection
            ExtractPath = OutputFolder & "\" & Left$(ZipFilePath, Len(ZipFilePath) - 4) & "\" 'Create subfolder with the same name as the zip file
            On Error Resume Next 'Avoid error if subfolder already exists
            MkDir ExtractPath
            On Error GoTo 0
            Debug.Print "Extracting from " & ZipFilePath & " to " & ExtractPath
            With CreateObject("Shell.Application").Namespace(ZipFilePath)
                For Each FileInZip In .Items
                    If InStr(1, FileInZip.Name, "unformatted", vbTextCompare) > 0 Then 'File name contains "unformatted"
                        .CopyHere FileInZip, 16 'Extract file to output folder without prompt and overwrite existing file
                        Debug.Print "Extracting " & FileInZip.Name & " from " & ZipFilePath & " to " & UnformattedFolderPath
                        .CopyHere FileInZip, 256 'Extract file to Unformatted folder without prompt and overwrite existing file
                        Debug.Print "Extracting " & FileInZip.Name & " from " & ZipFilePath & " to " & ExtractPath
                    End If
                Next
            End With
        End If
    Next
    
    'Display message box indicating completion
    MsgBox "Extraction complete.", vbInformation
    
End Sub

Tim Williams · Accepted Answer

This worked for me:

Sub ExtractUnformattedFilesFromZips()
    
    Dim ZipFiles As Variant, ZipFilePath As Variant, UnformattedFolderPath As Variant
    Dim FileInZip As Variant, ExtractPath As Variant, OutputFolder As Variant
    Dim haveDir As Boolean, oApp As Object
    
    ZipFiles = Application.GetOpenFilename(FileFilter:="Zip Files (*.zip), *.zip", _
           Title:="Select one or more zip files to extract from", MultiSelect:=True)
    If Not IsArray(ZipFiles) Then Exit Sub
    
    OutputFolder = UserSelectFolder( _
         "Select output folder where Unformatted folder will be created")
    If Len(OutputFolder) = 0 Then Exit Sub
    UnformattedFolderPath = OutputFolder & "\Unformatted\"
    EnsureDir UnformattedFolderPath
    
    Set oApp = CreateObject("Shell.Application")
    For Each ZipFilePath In ZipFiles
        
        haveDir = False 'reset flag
        Debug.Print "Extracting from " & ZipFilePath & " to " & ExtractPath
        
        With oApp.Namespace(ZipFilePath)
            For Each FileInZip In .Items
                If InStr(1, FileInZip.Name, "unformatted", vbTextCompare) > 0 Then 'File name contains "unformatted"
                    If Not haveDir Then 'already have an output folder for this zip?
                        ExtractPath = UnformattedFolderPath & BaseName(ZipFilePath)
                        EnsureDir ExtractPath
                        haveDir = True
                    End If
                    Debug.Print , FileInZip
                    oApp.Namespace(ExtractPath).CopyHere FileInZip, 256
                End If
            Next
        End With
    Next
    MsgBox "Extraction complete.", vbInformation
End Sub

'Ask user to select a folder
Function UserSelectFolder(sPrompt As String) As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Title = sPrompt
        If .Show = -1 Then UserSelectFolder = .SelectedItems(1)
    End With
End Function

'Make sure a folder exists
Sub EnsureDir(dirPath)
    If Len(Dir(dirPath, vbDirectory)) = 0 Then
        MkDir dirPath
    End If
End Sub

'get a filename without extension
Function BaseName(sName)
    BaseName = CreateObject("scripting.filesystemobject").getbasename(sName)
End Function

Excel VBA extract a specific file from zip

Answers (2)

Related Questions