时间戳

首页 > 解决方案 > 如何在VBA中解压缩同名文件？

vba - 如何在VBA中解压缩同名文件？

问题描述

我在尝试用 VBA 解压缩的目录中有一堆 zip 文件夹。我正在使用以下代码：

Sub UnzipAll()
    Dim oShell As Object: Set oShell = CreateObject("Shell.Application")
    Dim folder As Variant:  folder = Dir(ThisWorkbook.Path & "\Attachments\")

    While (folder <> "")
        If InStr(folder, ".zip") > 0 Then
            oShell.Namespace(ThisWorkbook.Path & "\Attachments\").CopyHere oShell.Namespace(ThisWorkbook.Path & "\Attachments\" & folder).Items
        End If
    folder = Dir
    Wend
End Sub

这工作得很好，但遇到了一个问题：当两个 zip 文件夹包含同名文件时，会弹出一个提示，询问我是要替换还是保留两者。

我怎样才能使它提取两个文件，同时保留两个文件？也许在一个之后加上一个数字来区分？

谢谢！

标签： vbaexcel

解决方案

免责声明：这完全是在黑暗中拍摄，但这可能会奏效。我只是不熟悉这个.Namespace或.CopyHere语法，但我认为这会起作用（在该位置已经存在的文件的末尾附加一个数字）。

Sub UnzipAll()
    Dim oShell As Object: Set oShell = CreateObject("Shell.Application")
    Dim folder As Variant:  folder = Dir(ThisWorkbook.Path & "\Attachments\")
    Dim i As Long

    i = 1

    While (folder <> "")

        If InStr(folder, ".zip") > 0 Then
            If Dir(ThisWorkbook.Path & "\Attachments\" & oShell.Namespace(ThisWorkbook.Path & "\Attachments\" & folder).Items) = "" Then
                oShell.Namespace(ThisWorkbook.Path & "\Attachments\").CopyHere oShell.Namespace(ThisWorkbook.Path & "\Attachments\" & folder).Items
            Else
                oShell.Namespace(ThisWorkbook.Path & "\Attachments\").CopyHere oShell.Namespace(ThisWorkbook.Path & "\Attachments\" & folder).Items & i
                i = i + 1
            End If
        End If

        folder = Dir

    Wend

End Sub

推荐阅读