Разархивируйте в VBA и переименуйте выходной файл в имя zip-файла

Я уже искал решение, но так и не нашел. Я просто хочу разархивировать файл и затем переименовать вывод в имя zip-файла (например, myfile.zip ---> myfile.xls). Мои zip-файлы содержат только один файл xls. Этот код почти делает то, что я хочу, но я получаю только пустой файл myfile.xls (0 КБ) в tempFolder:

Shell "cmd /c " & pathTo7zip & " e """ & file & """ -so > """ & tempFolder & Replace(Mid(file, InStrRev(file, "\") + 1), ".zip", ".xls") & """"

Я был бы очень признателен за любую помощь. Решение не обязательно должно быть основано на 7-zip, возможно, есть другое решение на базе Windows.


60
2

Ответы:

Решено

Вы можете использовать мою функцию 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:
'   Unpack 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
'
' 2023-10-28. 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"
    ' Extension of an archive file holding one or more files.
    Const TarExtensionName  As String = "tar"
    ' Extension of a compressed archive file holding one or more files.
    Const TgzExtensionName  As String = "tgz"
    ' Mandatory extension of zip file.
    Const ZipExtensionName  As String = "zip"
    Const ZipExtension      As String = "." & ZipExtensionName
    
    ' Constants for Shell.Application.
    Const DoOverwrite       As Long = &H0&
    Const NoOverwrite       As Long = &H8&
    Const YesToAll          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 Options             As Variant
    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) = TarExtensionName Or _
                FileSystemObject.GetExtensionName(Destination) = TgzExtensionName Or _
                FileSystemObject.GetExtensionName(Destination) = ZipExtensionName Then
                ' Do not unzip to a folder named *.cab, *.tar, 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.
            If OverWrite Then
                Options = DoOverwrite Or YesToAll
            Else
                Options = NoOverwrite Or YesToAll
            End If
            ShellApplication.Namespace(CVar(Destination)).CopyHere ShellApplication.Namespace(CVar(ZipTemp)).Items, Options
            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

Полный код на GitHub: VBA.Compress.

Полная документация на бирже экспертов:

Архивируйте и распаковывайте файлы и папки с помощью VBA с помощью Проводника Windows


Иногда проще заменить токен, когда используется много кавычек.

Используя ваш подход 7zip:

Sub TESTER()
    
    Dim runThis As String, srcZip As String, destFile As String
    'The whole text passed to cmd also needs quoting
    Const CMD = "cmd /c  "" ""<7zip>"" e ""<zip>"" -so > ""<dest>"" "" "
    
    srcZip = "C:\Temp\TestFile.zip"
    destFile = Replace(srcZip, ".zip", ".xlsx")
    
    runThis = ReplaceTokens(CMD, "<7zip>", "C:\Program Files\7-Zip\7z.exe", _
                                "<zip>", srcZip, _
                                "<dest>", destFile)
    Debug.Print runThis
    Shell runThis, vbNormalFocus
    
End Sub

'repalce tokens in `txt` using info supplied in `args`
Function ReplaceTokens(ByVal txt As String, ParamArray args())
    Dim i As Long, rv As String
    For i = LBound(args) To UBound(args) Step 2
        txt = Replace(txt, args(i), args(i + 1))
    Next i
    ReplaceTokens = txt
End Function