VBA 解压缩 zip 文件。错误 0x80010135

Question

我试图遍历文件夹中的所有 zip 文件，然后提取每个 zip 文件中的所有 excel 文件，包括 zip 文件中子文件夹中的 excel 文件。

我有以下代码循环遍历文件夹中的所有 zip 文件，并将每个压缩文件提取到特定文件夹。然而，其中一些 zip 文件包含具有长文件名的电子邮件文件，并且在提取时会引发错误 - 0x80010135 路径太长。

我的 objective 是从 zip 文件中仅提取 excel 个文件。是否可以跳过提取非 excel 文件，如果没有，是否有针对 0x80010135 错误的修复。

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

您可以遍历 Items 集合中的每个项目，并过滤 Excel 个文件。因此，例如，您可以替换 . . .

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

和

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

Answer 2

按照 Domenic @domenic 的建议更改代码后，我能够解决问题。下面是工作代码。

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

VBA 解压缩 zip 文件。错误 0x80010135

VBA to extract zip files. Error 0x80010135

excel

vba

unzip