获取错误'运行时错误-2147024894（80070002）'…当提取压缩文件
我有一个存档文件，其中包含多个子文件夹。
例如： C:\Documents and Settings\Owner\Desktop\Macro\Intermediación Financiera\2013\12\BCO_Ind.zip
在BCO_Ind.zip中包含这个子文件夹scbm\2013\09\fileThatIWant.xls
这些子文件夹对于每个存档文件都是不同的，尽pipe它具有相同的名称。 事情是我想从最后一个子文件夹的最后一个文件。
我修改了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 。
我试图从网站上search所有内容，但近一周没有find解决scheme。 这里是代码：
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
我也在开发macros中勾选了一些工具>引用，但仍然得到相同的错误。 我现在真的强调+沮丧。 请帮我解决它。 另外，是否有一个简单的代码作为我的参考文件被提取后从子文件夹中find文件？ 我真的很感激，如果有人可以分享的代码。
我有一个VBA解决scheme：
从所有压缩文件所在的根文件夹中，压缩文件中的所有文件都被抽取出来，而没有path。
然后我修改它，使得具有最深path的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
希望这可以帮助你。 圣诞快乐！
谢谢你，帕特里克！
这里是我的代码..我分开的意思是，我先解压该文件夹，并find该文件的确切path。 我从一些网站（忘了在哪个网站）find这个代码，根据我的需要修改了一下。 无论如何，非常感谢你的分享。 这里是代码：
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