title: EXCEL VBA- Export Workbook to Password-Protected ZIP file
body: <p>Is there anyway to modify Ron De Bruin's code to export the current workbook to a <em>password-protected</em> zip file.  I've looked around for quite some time, and can't figure out how to enable such an option.  </p>
  
  <p>Code is here: <a href="http://www.rondebruin.nl/win/s7/win001.htm" rel="noreferrer">http://www.rondebruin.nl/win/s7/win001.htm</a></p>
  
  <pre><code>Sub NewZip(sPath)
  'Create empty Zip File
  'Changed by keepITcool Dec-12-2005
      If Len(Dir(sPath)) &gt; 0 Then Kill sPath
      Open sPath For Output As #1
      Print #1, Chr$(80) &amp; Chr$(75) &amp; Chr$(5) &amp; Chr$(6) &amp; 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\"    '&lt;&lt; Change
      If Right(DefPath, 1) &lt;&gt; "\" Then
          DefPath = DefPath &amp; "\"
      End If
  
      'Create date/time string and the temporary xl* and Zip file name
      If Val(Application.Version) &lt; 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 &amp; Left(ActiveWorkbook.Name, _
      Len(ActiveWorkbook.Name) - Len(FileExtStr)) &amp; strDate &amp; ".zip"
  
      FileNameXls = DefPath &amp; Left(ActiveWorkbook.Name, _
      Len(ActiveWorkbook.Name) - Len(FileExtStr)) &amp; strDate &amp; 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: " &amp; FileNameZip
  
      Else
          MsgBox "FileNameZip or/and FileNameXls exist"
  
      End If
  End Sub
  </code></pre>