VBA to extract zip files. Error 0x80010135

Question

I am trying to loop through all zip files in a folder and then extract all excel files inside each zip files, including excel files that are in the subfolders inside the zip file.

I have the below code which loops through all zip files in a folder and extracts each of these zipped files to a specific folder. However some of these zip files contains email files with long file names and throws an error while extracting - 0x80010135 path too long.

My objective is to extract only excel files from the zip files. Is it possible to skip extracting non excel files, if not is there a fix for 0x80010135 error.

Copy Error Image

'Looping through all zip files in a folder
Public Sub UnZipAll()
Dim myFile As String, MyFolder As String, DestinationFolder As String
'the folder where zip file is
MyFolder = Range("E2").Value & "INPUT\"
Application.DisplayAlerts = False
Application.EnableEvents = False
'Loop through all zip files in a given directory
myFile = Dir(MyFolder & "*.zip")
Do While Len(myFile) > 0
    Call UnzipIt(MyFolder & "" & myFile, 0)
    Debug.Print myFile
    myFile = Dir
Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub

'Unziping zip files
Public Sub UnzipIt(ZipFile As String, Optional NewPath As Boolean = False)
    Dim oApp As Object
    Dim filename, FilePath, NewFilePath
    
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    
    filename = ZipFile
    If NewPath Then
        'optional, extract to a subfolder having the same name as the file
        FilePath = Left(filename, Len(filename) - 4) & "\"
        MkDir FilePath
    Else
        FilePath = Left(filename, InStrRev(filename, "\"))
    End If
    
    If filename <> "" Then
        Debug.Print filename
        'Extract the files into the selected folder
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(FilePath).CopyHere oApp.Namespace(filename).items
    End If
    
    Application.DisplayAlerts = True
    Application.EnableEvents = True
End Sub

Answer 1

You can loop through each item in the Items collection, and filter for Excel files. So, for example, you can replace . . .

oApp.Namespace(FilePath).CopyHere oApp.Namespace(filename).items

with

Dim itm As Object

For Each itm In oApp.Namespace(filename).items
    If LCase(Right(itm.Name, 5)) Like ".xls?" Then
        oApp.Namespace(FilePath).CopyHere itm
    End If
Next itm