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

我还在开发宏中勾选了一些工具＆gt;引用，但它仍然会得到相同的错误。我现在真的很压力+沮丧。请帮我修理一下。另外，是否有一个简单的代码作为我的引用，在文件被提取后从子文件夹中查找文件？如果有人可以分享代码，我真的很感激。

Answer 1

我有一个VBA解决方案：

从所有zip文件所在的根文件夹中，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

希望这会帮助你。 Merry X'mas！

Answer 2

非常感谢Patrick！

这是我的代码..我单独表示，我首先解压缩该文件夹并找到该文件的确切路径。这个代码我从一些网站上找到了（忘了在哪个网站上），我根据自己的需要进行了一些修改。无论如何，非常感谢你的分享。这是代码：

 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

获取错误'运行时错误-2147024894（80070002）'...解压zip文件时

2 个答案: