将文件直接复制和替换到 .zip 文件夹中的 VBA 代码？

Question

所以我正在尝试制作一个宏来替换所选 Excel 工作簿（在“filename.zip/xl”文件夹中）的 vbaProject.bin，但我在实际复制更新 vbaProject 时遇到了问题.bin 到 zip 文件夹中。我尝试的第一行（现已注释掉）是：

Call fso.CopyFile(tempBinFile, newFileName & "\xl\", True)

这给了我一个找不到该路径的错误，我认为这是因为它在一个 zip 文件中。所以接下来我尝试了这一行：

ShellApp.Namespace(newFileName & "\xl\").CopyHere tempBinFile, 16

它没有给出错误，但似乎也没有实际做任何事情。有没有办法使用 VBA 直接粘贴（和替换）到 zip 文件的子文件夹中？我也尝试先解压缩文件然后重新压缩，但我得到了不同的错误，所以如果有人有一个好的解决方案来代替，那也会有帮助。

Sub ReplaceVBABin()

    Dim strFileName As String
    Dim newFileName As String
    Dim pathName As String
    Dim tempBinFile As String
    Dim xlFolderName As String
    Dim fso As Object
    Dim ShellApp As Object

    Set ShellApp = CreateObject("Shell.Application")
    
    Set fso = VBA.CreateObject("Scripting.FileSystemObject")
    
    'Select file to patch
    strFileName = Application.GetOpenFilename("Excel Macro Enabled Workbook (*.xlsm), *.xlsm")
    If strFileName = "False" Then Exit Sub
    
    'Rename file to .zip
    newFileName = Replace(strFileName, ".xlsm", ".zip")
    Name strFileName As newFileName
    
    pathName = fso.GetParentFolderName(strFileName) & "\"
    
    'Add copy of embedded vbaProject.bin to directory
    tempBinFile = CreateTempBin(pathName)
    
    'Copy and replace vbaProject.bin in folder
    'Call fso.CopyFile(tempBinFile, newFileName & "\xl\", True)
    ShellApp.Namespace(newFileName & "\xl\").CopyHere tempBinFile, 16
    
    'Delete temp file
    Kill tempBinFile
    
    'Name zip file back to .xlsm
    Name newFileName As strFileName
    
End Sub

Answer 1

使用7-Zip 的命令行选项，这显示了提取、删除然后更新的 3 个步骤，您可以根据需要进行调整。它将 xl 目录提取到一个临时文件夹，从工作簿中删除 xl 文件夹，然后用更新替换它。我认为您可能可以省去删除，只需提取，替换 vbaProject.bin 文件，然后进行更新。

Sub ReplaceVBABin7z()

    Const SevenZipExe = "C:\Program Files\7-Zip\7z.exe"
    Const tmpDir = "c:\temp\7z\"
    Dim qq As String: qq = Chr(34)  '"
    
    ' check 7-zip exe exists
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.fileexists(SevenZipExe) Then
        MsgBox SevenZipExe & " not found", vbCritical, "7-Zip Not found"
        Exit Sub
    End If
    
    ' create list of commands available
    Dim cmd As String, pid As Double
    'cmd = "cmd /c """ & SevenZipExe & """ >" & tmpDir & "7-Zip_Commands.txt"
    'pid = Shell(cmd, vbHide)
    'MsgBox "Command List see " & tmpDir & "7-Zip_Commands.txt", vbInformation, pid
    
    Dim path As String
    Dim strFileName As String, strBinName As String

    ' select workbook
    path = ThisWorkbook.path & "\"
    strFileName = Application.GetOpenFilename("Excel Macro Enabled Workbook (*.xlsm), *.xlsm")
    If strFileName = "False" Then Exit Sub
    strFileName = qq & strFileName & qq ' quoted for spaces in filename
       
ext:
    ' extract xl dir and sub dirs into tmpdir
    cmd = qq & SevenZipExe & qq & " x -r -y -o" & qq & tmpDir & qq & " " & _
           strFileName & " xl"
    pid = Shell(cmd, vbHide)
    Debug.Print pid, cmd
    MsgBox "xl directory from " & strFileName & " extracted to " & tmpDir, vbInformation, "EXTRACT pid=" & pid
    'Shell "Taskkill -pid " & pid

del:
    ' delete xl\vbaProject.bin dir and subdir
    strBinName = "xl\vbaProject.bin"
    cmd = qq & SevenZipExe & qq & " d -r " & _
          strFileName & " " & strBinName
    pid = Shell(cmd, vbHide)
    Debug.Print pid, cmd
    MsgBox strBinName & " deleted from " & strFileName, vbInformation, "DELETE pid=" & pid
    'Shell "Taskkill -pid " & pid

upd:
    ' update xl dir and subdir
    cmd = qq & SevenZipExe & qq & " u -r -y -stl " & _
          strFileName & " " & qq & tmpDir & "xl" & qq
    pid = Shell(cmd, vbHide)
    Debug.Print pid, cmd
    MsgBox strFileName & " updated from " & tmpDir, vbInformation, "UPDATE pid=" & pid
    'Shell "Taskkill -pid " & pid

End Sub