VBA代码复制和替换文件直接到.zip文件夹?

Question

所以我想做一个宏，取代所选Excel工作簿的vbaProject.bin(在"filename.zip/xml "文件夹)，但我遇到了一个问题，实际复制更新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文件夹，然后用update替换它。我想你也许可以省去删除，只是提取，替换vbaProject.bin文件，然后做更新。

Sub ReplaceVBABin7z()
Const SevenZipExe = "C:Program Files7-Zip7z.exe"
Const tmpDir = "c:temp7z"
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 xlvbaProject.bin dir and subdir
strBinName = "xlvbaProject.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