Save as zip with a password

**Ang12345** · 10-19-2010, 10:29 AM

Hello,
I have an Excel VBA with the following code to save a file

     Dim strExportDate As String
    strExportDate = Month(Now) & "." & Day(Now) & "." & Year(Now)
    
    ChDir "Y:\global\VOTING INSTRUCTIONS\P"
    ActiveWorkbook.SaveAs Filename:="Y:\global\VOTING INSTRUCTIONS\P\Instructions for P." & strExportDate & ".xls", FileFormat:=xlExcel8, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
        CreateBackup:=False

It works fine, but I would like to know if there is a way I can get it to save as a zip file with a password.

Thanks

**royUK** · 10-19-2010, 10:32 AM

There's sample code here

**Ang12345** · 10-26-2010, 12:49 PM

Is there a more up to date example? This is not working on excel 2007. I am also trying to zip with secure zip with a password if that makes a difference. It is my windows default.

**Ang12345** · 12-23-2010, 09:15 AM

Hello,
I am using the code from the page as suggested

Sub Zip_ActiveWorkbook()
    Dim strDate As String, DefPath As String
    Dim FileNameZip, FileNameXls
    Dim oApp As Object
    Dim FileExtStr As String

    DefPath = "C:\Documents and Settings\cignaa\My Documents\Agendas"    '<< 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

I am getting an error on the line

oApp.Namespace(FileNameZip).CopyHere FileNameXls

The error is:

Run-time error'-2147024894 (80070002)':
Method 'NameSpace' of object 'IShellDispatch4' failed

any idea what is wrong?

**Leith Ross** · 12-23-2010, 02:22 PM

Hello Ang12345,

This version has worked well for me. Try it out and let me know what happens.

'Written: December 05, 2007
'Author: Leith Ross
'Summary: Uses WinZip to zip or unzip a file and save it to an archive.

 Private Declare Function ShellExecute _
  Lib "Shell32.dll" _
    Alias "ShellExecuteA" _
     (ByVal hWnd As Long, _
      ByVal lpOperation As String, _
      ByVal lpFile As String, _
      ByVal lpParameters As String, _
      ByVal lpDirectory As String, _
      ByVal nShowCmd As Long) As Long


Sub ZipFile(FileName As String, Optional ByVal Password As String)

  Dim BackSlash As Long
  Dim CmdLine As String
  Dim Ext As Long
  Dim FilePath As String
  Dim RetVal As Long
  Dim ZipName As String
    
   'If no path is specified use the current directory
    BackSlash = InStrRev(FileName, "\")
    If BackSlash = 0 Then
       FilePath = CurDir & "\"
    Else
       FilePath = ""
    End If
    
   'Check if file exists
    If Dir(FilePath & FileName) = "" Then
       MsgBox "File Not Found" & vbCrLf & "  " & FilePath & FileName
       Exit Sub
    End If
    
   'Name for the zip archive
    Ext = InStrRev(FileName, ".")
      If Ext = 0 Then
         ZipName = FileName & ".zip"
      Else
         ZipName = Left(FileName, Ext) & "zip"
      End If
    
   'Command line string - file names must include quotes
    If Password = "" Then
       CmdLine = "-min -a -en " & Chr$(34) & ZipName & Chr$(34) & " " _
               & Chr$(34) & FileName & Chr$(34)
    Else
       CmdLine = "-min -a -en -s" & Chr$(34) & Password & Chr$(34) _
               & " " & Chr$(34) & ZipName & Chr$(34) & " " _
               & Chr$(34) & FileName & Chr$(34)
    End If
            
    'Command line String to Unzip a file
     'CmdLine = "-min -e " & Chr$(34) & ZipFileName & Chr$(34) & " " _
     '       & FolderPath
        
     'Zip the file and save it in the archive
      RetVal = ShellExecute(0&, "", "WinZip32.exe", CmdLine, FilePath, 1&)
  
   'Check for Errors are from 0 to 32
    If RetVal <= 32 Then
       Select Case RetVal
         Case 2     'SE_ERR_FNF
           Msg = "File not found"
         Case 3      'SE_ERR_PNF
           Msg = "Path not found"
         Case 5      'SE_ERR_ACCESSDENIED
           Msg = "Access denied"
         Case 8      'SE_ERR_OOM
           Msg = "Out of memory"
         Case 32     'SE_ERR_DLLNOTFOUND
           Msg = "DLL not found"
         Case 26     'SE_ERR_SHARE
           Msg = "A sharing violation occurred"
         Case 27     'SE_ERR_ASSOCINCOMPLETE
           Msg = "Incomplete or invalid file association"
         Case 28     'SE_ERR_DDETIMEOUT
           Msg = "DDE Time out"
         Case 29     'SE_ERR_DDEFAIL
           Msg = "DDE transaction failed"
         Case 30     'SE_ERR_DDEBUSY
           Msg = "DDE busy"
         Case 31     'SE_ERR_NOASSOC
           Msg = "Default Email not configured"
         Case 11     'ERROR_BAD_FORMAT
           Msg = "Invalid EXE file or error in EXE image"
         Case Else
           Msg = "Unknown error"
       End Select
      Msg = "File Not Zipped - " & Msg & vbCrLf & "Error " & RetVal
      MsgBox Msg, vbExclamation + vbOKOnly
    End If
  
End Sub

Macro Example

Sub Test()

 'Create a zipped copy of the file and save it to the same directory (C:\Test File.zip)
  ZipFile FileName:="C:\Test File.txt", Password:="123"
  
End Sub

**Ang12345** · 12-28-2010, 03:51 PM

Hi Leith,
I dont think that will work because it uses WinZip. I have to use securezip. I gave it a shot and I am getting an error for

'Zip the file and save it in the archive
      RetVal = ShellExecute(0&, "", "WinZip32.exe", CmdLine, FilePath, 1&

sub or function undefined

**Leith Ross** · 12-29-2010, 12:33 AM

Hello Ang12345,

I will look into to this and see if it has command line capability. If it does then it maybe possible to initiate zipping the file with VBA.

**Rolly_Sefu** · 01-05-2021, 10:47 AM

Hello, i am trying a similar code with 7zip, but i'm having a trouble with consistency, first test is successful, i delete the zip file remake the test and then not all zipped files are password protected.
Any ideas why ? do i somehow need to reset zip parameters after each item ?

Sub Test()
LastRow = Sheets("sheet1").Range("A" & Rows.Count).End(xlUp).Row
Set Rng = Sheets("sheet1").Range("A2:A" & LastRow)
For Each cell In Rng
    Sheets("Sheet2").Range("B2") = cell.Value
    Sheets("Sheet2").Range("B3") = cell.Offset(0, 1).Value
    Sheets("Sheet2").Range("B5") = cell.Offset(0, 2).Value
    UserName = Sheets("Sheet2").Range("B2") & " " & Sheets("Sheet2").Range("B3")
    
    Sheets("Sheet2").ExportAsFixedFormat Type:=xlTypePDF, _
    FileName:="C:\Users\Roland\Desktop\Zip test\" & UserName & ".pdf"
    
    strDestFileName = "C:\Users\Roland\Desktop\Zip test\" & UserName & ".zip"
    strSourceFileName = "C:\Users\Roland\Desktop\Zip test\" & UserName & ".pdf"
    str7ZipPath = "C:\Program Files\7-Zip\7z.exe"
    strPassword = cell.Offset(0, 3)
    
    strCommand = str7ZipPath & " -p" & strPassword & " a -tzip """ & strDestFileName & """ """ & strSourceFileName & """"
    Shell strCommand
    Application.Wait (Now + TimeValue("0:00:01"))
    
    Kill strSourceFileName
    
Next cell
End Sub

Thank you

**FDibbins** · 01-06-2021, 02:19 AM

Originally Posted by Rolly_Sefu

Hello, i am trying a similar code with 7zip, but i'm having a trouble with consistency, first test is successful, i delete the zip file remake the test and then not all zipped files are password protected.
Any ideas why ? do i somehow need to reset zip parameters after each item ?

Sub Test()...

Thank you

Administrative Note:

Welcome to the forum.

We are happy to help, however whilst you feel your request is similar to this thread, experience has shown that things soon get confusing when answers refer to particular cells/ranges/sheets which are unique to your post and not relevant to the original.

Please see Forum Rule #4 about hijacking and start a new thread for your query.

If you are not familiar with how to start a new thread see the FAQ: How to start a new thread