獲取錯誤'運行時錯誤-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