EXCEL VBA - 将工作簿导出到受密码保护的 ZIP 文件
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/22448766/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
EXCEL VBA- Export Workbook to Password-Protected ZIP file
提问by Parseltongue
Is there anyway to modify Ron De Bruin's code to export the current workbook to a password-protectedzip file. I've looked around for quite some time, and can't figure out how to enable such an option.
无论如何修改 Ron De Bruin 的代码以将当前工作簿导出到受密码保护的zip 文件。我环顾四周很长一段时间，无法弄清楚如何启用这样的选项。
Code is here: http://www.rondebruin.nl/win/s7/win001.htm
代码在这里：http: //www.rondebruin.nl/win/s7/win001.htm
Sub NewZip(sPath)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
If Len(Dir(sPath)) > 0 Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub
Sub Zip_ActiveWorkbook()
Dim strDate As String, DefPath As String
Dim FileNameZip, FileNameXls
Dim oApp As Object
Dim FileExtStr As String
DefPath = "C:\Users\Ron\test\" '<< Change
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
'Create date/time string and the temporary xl* and Zip file name
If Val(Application.Version) < 12 Then
FileExtStr = ".xls"
Else
Select Case ActiveWorkbook.FileFormat
Case 51: FileExtStr = ".xlsx"
Case 52: FileExtStr = ".xlsm"
Case 56: FileExtStr = ".xls"
Case 50: FileExtStr = ".xlsb"
Case Else: FileExtStr = "notknown"
End Select
If FileExtStr = "notknown" Then
MsgBox "Sorry unknown file format"
Exit Sub
End If
End If
strDate = Format(Now, " yyyy-mm-dd h-mm-ss")
FileNameZip = DefPath & Left(ActiveWorkbook.Name, _
Len(ActiveWorkbook.Name) - Len(FileExtStr)) & strDate & ".zip"
FileNameXls = DefPath & Left(ActiveWorkbook.Name, _
Len(ActiveWorkbook.Name) - Len(FileExtStr)) & strDate & FileExtStr
If Dir(FileNameZip) = "" And Dir(FileNameXls) = "" Then
'Make copy of the activeworkbook
ActiveWorkbook.SaveCopyAs FileNameXls
'Create empty Zip File
NewZip (FileNameZip)
'Copy the file in the compressed folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameZip).CopyHere FileNameXls
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).items.Count = 1
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
'Delete the temporary xls file
Kill FileNameXls
MsgBox "Your Backup is saved here: " & FileNameZip
Else
MsgBox "FileNameZip or/and FileNameXls exist"
End If
End Sub
采纳答案by Oliver Lockett
I've found an accepted answer for this on another siteusing 7Zip......
我在另一个使用 7Zip 的网站上找到了一个公认的答案......
strDestFileName = "c:\temp\TestZipFile.zip"
strSourceFileName = "c:\temp\test.pdf"
str7ZipPath = "C:\Program Files-Zipz.exe"
strPassword = "MyPassword"
strCommand = str7ZipPath & " -p" & strPassword & " a -tzip """ & strDestFileName & """ """ & strSourceFileName & """"
Shell strCommand
