将文件解压缩到单个文件夹？

Question

有人可以帮助我将unzip 文件放入与 zip 文件名同名的单个文件夹中吗？

基本上，我的代码可以从一个文件夹中读取 zip 文件并将其解压缩到另一个文件夹中。但我想为每个 zip 文件 create a new folder 以便它们被很好地隔离。

长话短说，我正在寻找 Windows Extract to 选项，而不是 Extract here。

下面的代码 sn-p。在fileName = Dir() 给出错误

While Len(fileName) <> 0 
    If Left(fileName, 1) <> "." Then 
        zipFileName = folderPathZip & fileName 
        If Dir(unZipFolderName & "\" & fileName) = Empty Then 
            MkDir unZipFolderName & "\" & fileName
        End If 
        Set ShellApp = CreateObject("Shell.Application")
        ShellApp.Namespace(unZipFolderName & "\" & fileName).CopyHere ShellApp.Namespace(zipFileName).items 
    End If 

    fileName = Dir()

Answer 1

你可以从VBA.Compress使用我的UnZip函数

' Unzip files from a zip file to a folder using Windows Explorer.
' Default behaviour is similar to right-clicking a file/folder and selecting:
'   Unzip all ...
'
' Parameters:
'   Path:
'       Valid (UNC) path to a valid zip file. Extension can be another than "zip".
'   Destination:
'       (Optional) Valid (UNC) path to the destination folder.
'   Overwrite:
'       (Optional) Leave (default) or overwrite an existing folder.
'       If False, an existing folder will keep other files than those in the extracted zip file.
'       If True, an existing folder will first be deleted, then recreated.
'
'   Path and Destination can be relative paths. If so, the current path is used.
'
'   If success, 0 is returned, and Destination holds the full path of the created folder.
'   If error, error code is returned, and Destination will be zero length string.
'
' Early binding requires references to:
'
'   Shell:
'       Microsoft Shell Controls And Automation
'
'   Scripting.FileSystemObject:
'       Microsoft Scripting Runtime
'
' 2017-10-22. Gustav Brock. Cactus Data ApS, CPH.
'
Public Function UnZip( _
    ByVal Path As String, _
    Optional ByRef Destination As String, _
    Optional ByVal Overwrite As Boolean) _
    As Long
   
#If EarlyBinding Then
    ' Microsoft Scripting Runtime.
    Dim FileSystemObject    As Scripting.FileSystemObject
    ' Microsoft Shell Controls And Automation.
    Dim ShellApplication    As Shell
   
    Set FileSystemObject = New Scripting.FileSystemObject
    Set ShellApplication = New Shell
#Else
    Dim FileSystemObject    As Object
    Dim ShellApplication    As Object
    Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
    Set ShellApplication = CreateObject("Shell.Application")
#End If
               
    ' Extension of a cabinet file holding one or more files.
    Const CabExtensionName  As String = "cab"
    ' Mandatory extension of zip file.
    Const ZipExtensionName  As String = "zip"
    Const ZipExtension      As String = "." & ZipExtensionName
    ' Constants for Shell.Application.
    Const OverWriteAll      As Long = &H10&
    ' Custom error values.
    Const ErrorNone         As Long = 0
    Const ErrorOther        As Long = -1
   
    Dim ZipName             As String
    Dim ZipPath             As String
    Dim ZipTemp             As String
    Dim Result              As Long
   
    If FileSystemObject.FileExists(Path) Then
        ' The source is an existing file.
        ZipName = FileSystemObject.GetBaseName(Path)
        ZipPath = FileSystemObject.GetFile(Path).ParentFolder
    End If
   
    If ZipName = "" Then
        ' Nothing to unzip. Exit.
        Destination = ""
    Else
        ' Select or create destination folder.
        If Destination <> "" Then
            ' Unzip to a custom folder.
            If _
                FileSystemObject.GetExtensionName(Destination) = CabExtensionName Or _
                FileSystemObject.GetExtensionName(Destination) = ZipExtensionName Then
                ' Do not unzip to a folder named *.cab or *.zip.
                ' Strip extension.
                Destination = FileSystemObject.BuildPath( _
                    FileSystemObject.GetParentFolderName(Destination), _
                    FileSystemObject.GetBaseName(Destination))
            End If
        Else
            ' Unzip to a subfolder of the folder of the zipfile.
            Destination = FileSystemObject.BuildPath(ZipPath, ZipName)
        End If
           
        If FileSystemObject.FolderExists(Destination) And Overwrite = True Then
            ' Delete the existing folder.
            FileSystemObject.DeleteFolder Destination, True
        End If
        If Not FileSystemObject.FolderExists(Destination) Then
            ' Create the destination folder.
            FileSystemObject.CreateFolder Destination
        End If
       
        If Not FileSystemObject.FolderExists(Destination) Then
            ' For some reason the destination folder does not exist and cannot be created.
            ' Exit.
            Destination = ""
        Else
            ' Destination folder existed or has been created successfully.
            ' Resolve relative paths.
            Destination = FileSystemObject.GetAbsolutePathName(Destination)
            Path = FileSystemObject.GetAbsolutePathName(Path)
            ' Check file extension.
            If FileSystemObject.GetExtensionName(Path) = ZipExtensionName Then
                ' File extension is OK.
                ZipTemp = Path
            Else
                ' Rename the zip file by adding a zip extension.
                ZipTemp = Path & ZipExtension
                FileSystemObject.MoveFile Path, ZipTemp
            End If
            ' Unzip files and folders from the zip file to the destination folder.
            ShellApplication.Namespace(CVar(Destination)).CopyHere ShellApplication.Namespace(CVar(ZipTemp)).Items, OverWriteAll
            If ZipTemp <> Path Then
                ' Remove the zip extension to restore the original file name.
                FileSystemObject.MoveFile ZipTemp, Path
            End If
        End If
    End If
   
    Set ShellApplication = Nothing
    Set FileSystemObject = Nothing
   
    If Err.Number <> ErrorNone Then
        Destination = ""
        Result = Err.Number
    ElseIf Destination = "" Then
        Result = ErrorOther
    End If
   
    UnZip = Result
     
End Function

完整的文档在这里：

Zip and unzip files and folders with VBA the Windows Explorer way