VBA to extract zip files. Error 0x80010135-CodePudding

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

CodePudding user response：

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

CodePudding user response：

I was able to resolve the issue after making changes to the code as suggested by Domenic @domenic. Below is the working code.

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
    Dim ZipFilePath As Variant
    ZipFilePath = MyFolder & myFile
    Debug.Print ZipFilePath
    Call zpath(ZipFilePath)
    myFile = Dir
Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub



Sub zpath(ZipFilePath As Variant)
Debug.Print ZipFilePath
Dim sh, n
Set sh = CreateObject("shell.application")
Set n = sh.Namespace(ZipFilePath)
recur sh, n
End Sub


Sub recur(sh, n)
Dim i, subn
INPUT_FOLDER = Range("E2").Value & "INPUT\"
For Each i In n.items
    If i.isfolder Then
        Set subn = sh.Namespace(i)
        recur sh, subn
        Else
        If LCase(Right(i.Name, 5)) Like ".xls?" Then
        Debug.Print i.Path
        sh.Namespace(INPUT_FOLDER).CopyHere i
        End If
    End If
Next
Exit Sub
End Sub