获取错误'运行时错误-2147024894（80070002）'...当提取压缩文件

Question

我有一个存档文件，其中包含多个子文件夹。

例如：C:\Documents and Settings\Owner\Desktop\Macro\Intermediación Financiera\2013\12\BCO_Ind.zip

在BCO_Ind.zip包含此子文件夹scbm\2013\09\fileThatIWant.xls

这些子文件夹是每个存档文件不同，尽管它具有相同的名称。 事情是我想要最后一个子文件夹的最后一个文件。

我修改了代码从http://excelexperts.com/unzip-files-using-vba和www.rondebruin.nl/win/s7/win002.htm

问题是，我得到一个错误是： run-time error -2147024894(80070002)': Method 'Namespace' of Object 'IShellDispatch4' failed。

我尝试从网站上搜索所有内容，但是我几乎没有找到解决方案将近一周。 下面是代码：

Sub TestRun() 
'Change this as per your requirement 
Call unzip("C:\Documents and Settings\Owner\Desktop\Macro\Intermediación Financiera\2013\12\", "C:\Documents and Settings\Owner\Desktop\Macro\Intermediación Financiera\2013\12\BCO_Ind.zip") 
End Sub 

Public Function unzip(targetpath As String, filename As Variant, Optional SCinZip As String, _ 
        Optional excelfile As String) As String '(targetpath As String, filename As Variant) 

Dim strScBOOKzip As String, strScBOOK As String: strScBOOK = targetpath 
Dim targetpathzip As String, excelpath As String 
Dim bzip As Boolean: bzip = False 
Dim oApp As Object 
Dim FileNameFolder As Variant 
Dim fileNameInZip As Object 
Dim objFSO As Scripting.FileSystemObject 
Dim filenames As Variant: filenames = filename 

If Right(targetpath, 1) <> Application.PathSeparator Then 
    targetpathzip = targetpath & Application.PathSeparator 
Else 
    targetpathzip = targetpath 
End If 

FileNameFolder = targetpathzip 
Set objFSO = CreateObject("Scripting.FileSystemObject") 
Set oApp = CreateObject("Shell.Application") 
''-----i get an error in here 
For Each fileNameInZip In oApp.Namespace(filenames).Items 
    If objFSO.FolderExists(FileNameFolder & fileNameInZip) Then 
    objFSO.DeleteFolder FileNameFolder & fileNameInZip, True: Sleep 1000 
    End If 
''-----i get an error in here too 
    oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(filename).Items.item(CStr(fileNameInZip)) 
    bzip = True 
Next fileNameInZip 

If bzip Then 
    excelpath = findexactfile(targetpath) ' this will go to the function that find the file from subfolders 
Else 
    excelpath = "" 
End If 
searchfolder = FileNameFolder & fileNameInZip 

finish: 
    unzip = excelpath 
    Set objFSO = Nothing 
    Set oApp = Nothing 
End Function 

我也勾出一些工具>开发宏引用，但它仍然得到同样的错误。我现在真的很紧张+沮丧。请帮我解决它。另外，是否有一个简单的代码作为我的参考文件在提取文件后从子文件夹中查找文件？我真的很感激，如果有人可以分享代码。

Answer 1

我有一个VBA解决方案：

从所有的zip文件所在的根文件夹，压缩文件中的所有文件不带路径提取。

然后我修改它，使zip文件中具有最深路径的第一个文件将被提取到预定义的文件夹。这应该符合你的情况。

Option Explicit 

Const sEXT As String = "zip" 
Const sSourceFDR As String = "C:\Debug" ' Folder that contains all the zip files 
Const sTargetFDR As String = "C:\Test" ' Folder to store all the files within the zip 

Dim oFSO As Object, oShell As Object 
Dim oCopy As Object ' Comment out to extract all files without path 

Sub StartUnzipAll() 
    Set oFSO = CreateObject("Scripting.FileSystemObject") 
    Set oShell = CreateObject("Shell.Application") 
    Debug.Print Now & vbTab & "StartUnzipAll() Started" 

    UnZipFolder sTargetFDR, sSourceFDR 

    ' Only copy the first file in deepest folder: 
    ' Comment out If-Block to extract all files without path 
    If Not oCopy Is Nothing Then 
     oShell.Namespace(sTargetFDR & Application.PathSeparator).CopyHere oCopy 
    End If 

    Debug.Print Now & vbTab & "StartUnzipAll() Finished" 
    Set oShell = Nothing 
    Set oFSO = Nothing 
End Sub 

Private Sub UnZipFolder(sTgtFDR As String, sSrcFDR As String) 
    Dim oFile As Variant, oFDR As Variant 
    ' Process all files in sSrcFDR 
    For Each oFile In oFSO.GetFolder(sSrcFDR).Files 
     If oFSO.GetExtensionName(oFile) = sEXT Then 
      UnZipFile sTgtFDR, oFile.Path 
     End If 
    Next 
    ' Recurse all sub folders in sSrcFDR 
    For Each oFDR In oFSO.GetFolder(sSrcFDR).SubFolders 
     UnZipFolder sTgtFDR, oFDR.Path 
    Next 
End Sub 

Private Sub UnZipFile(sFDR As String, oFile As Variant) 
    Dim oItem As Object 
    For Each oItem In oShell.Namespace(oFile).Items 
     ' Process files only (identified by "." in the name) 
     If InStr(1, oItem.Name, ".", vbTextCompare) > 0 Then 
      Debug.Print "File """ & oItem.Name & """ in """ & oItem.Path & """" 
      ' Comment out If-Block to extract all files without path 
      If oCopy Is Nothing Then 
       Set oCopy = oItem 
      Else 
       If UBound(Split(oItem.Path, Application.PathSeparator)) > UBound(Split(oCopy.Path, Application.PathSeparator)) Then 
        Set oCopy = oItem 
       End If 
      End If 
      ' Uncomment to extract all files without path 
      'Debug.Print "Extracting """ & oIem.Name & """ to """ & sFDR & """" 
      'oShell.Namespace(sFDR & Application.PathSeparator).CopyHere oItem 
     Else 
      ' No file extension, Recurse into this folder 
      UnZipFile sFDR, oItem.Path 
     End If 
    Next 
End Sub 

希望这可以帮助你。圣诞快乐！

Answer 2

非常感谢你帕特里克！

这是我的代码..我分开做的意思是，我先解压该文件夹，然后找到该文件的确切路径。我从一些网站（忘记了哪个网站）找到的这段代码，根据我的需要修改了一下。无论如何，非常感谢你的分享。 下面是代码：

Public Function unzip(strScBOOK As String, strScBOOKzip As Variant, _ 
        Optional SCinZip As String, Optional excelScfile As String) As Boolean 

Dim targetpathzip As Variant, excelpath As String, bUNZIP As Boolean: bUNZIP = False 
Dim oApp As Object 
Dim FileNameFolder As Variant 
Dim fileNameInZip As Variant 
Dim objFSO As Scripting.FileSystemObject 

If Right(strScBOOK, 1) <> Application.PathSeparator Then 
    targetpathzip = strScBOOK & Application.PathSeparator 
Else 
    targetpathzip = strScBOOK 
End If 

FileNameFolder = targetpathzip 
Set objFSO = CreateObject("Scripting.FileSystemObject") 
Set oApp = CreateObject("Shell.Application") 
For Each fileNameInZip In oApp.Namespace(strScBOOKzip).Items 
    If objFSO.FolderExists(FileNameFolder & fileNameInZip) Then 
     objFSO.DeleteFolder FileNameFolder & fileNameInZip, True: Sleep 1000 
    End If 
    oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(strScBOOKzip).Items.item(CStr(fileNameInZip)) 
    bUNZIP = True 
Next fileNameInZip 

finish: 
    unzip = bUNZIP 
    Set objFSO = Nothing 
    Set oApp = Nothing 
End Function 

Public Function findexactpathfile(refstrScBOOK As String, refstrScBOOKzip As Variant, SCinZip As String, excelScfile As String) As String 

Dim objrootfolder As New Scripting.FileSystemObject 
Dim subfolder As Folder, sourcefile As Variant, excelfile As String 
Dim rootfolder As Scripting.Folder 
Dim fileNameInZip As Variant, filename As Variant, deleteZip As Variant 
Dim oApp As Object 
Dim objFSO As Scripting.FileSystemObject 

sourcefile = Left(refstrScBOOK, Len(refstrScBOOK) - 1) 
If Right(refstrScBOOK, 1) <> Application.PathSeparator Then 
    sourcefile = refstrScBOOK 
Else 
    sourcefile = Left(refstrScBOOK, Len(refstrScBOOK) - 1) 
End If 

Set rootfolder = objrootfolder.GetFolder(sourcefile) 
filename = findexcelinsubfolder(rootfolder, True, SCinZip) 
If filename <> "" Then 
    fileNameInZip = Trim(Split(filename, "\")(UBound(Split(filename, "\")))) 
    sourcefile = refstrScBOOK 
    excelfile = MoveandRenameFile(CStr(filename), CStr(sourcefile), CStr(fileNameInZip), excelScfile) 
End If 
If excelfile <> "" Then 
    Set objFSO = CreateObject("Scripting.FileSystemObject") 
    Set oApp = CreateObject("Shell.Application") 
    For Each deleteZip In oApp.Namespace(CVar(refstrScBOOKzip)).Items 
     If objFSO.FolderExists(sourcefile & deleteZip) Then 
      objFSO.DeleteFolder sourcefile & deleteZip, True: Sleep 1000 
     End If 
    Next deleteZip 
End If 

finish: 
    findexactpathfile = excelfile 
    Set rootfolder = Nothing 
    Set oApp = Nothing 
End Function 

Public Function findexcelinsubfolder(objFolder As Scripting.Folder, IncludeSubFolders As Boolean, _ 
           SCinZip As String, Optional filename As Variant) As String 

Dim fileItem As Scripting.File 
Dim subfileItem As Scripting.Folder 
Dim Fname As Variant 
Dim strTEMP As String 
IncludeSubFolders = True 

For Each fileItem In objFolder.Files 
    '---amend like ".xls" to excel file in direction path(obs file) 
    If fileItem.Name Like "*" & SCinZip & "*.xls*" Then 
     Fname = fileItem.Path 
     IncludeSubFolders = False 
     Exit For 
    End If 
Next fileItem 

If IncludeSubFolders Then 
    For Each subfileItem In objFolder.SubFolders 
     Fname = findexcelinsubfolder(subfileItem, IncludeSubFolders, SCinZip, Fname) 
     If Fname <> "" Then Exit For 
    Next subfileItem 
End If 

finish: 
    findexcelinsubfolder = Fname 
    Exit Function 
End Function 

Function MoveandRenameFile(sourcepath As String, targetpath As String, excelname As String, excelfile As String) As String 

    Dim fso As Object 

    Set fso = CreateObject("Scripting.FileSystemObject") 
    If fso.FileExists(targetpath & excelfile) Then 
    '---delete the file, move and rename in the targetpath 
     fso.DeleteFile targetpath & excelfile, True: Sleep 1000 
     Name sourcepath As targetpath & excelfile 
    Else 
    '---move and rename in the targetpath 
     Name sourcepath As targetpath & excelfile 
    End If 

finish: 
    MoveandRenameFile = targetpath & excelfile 
    Set fso = Nothing 
End Function