Passwording zip file via vba

Woody

New Member
Joined
Jan 3, 2005
Messages
5
Hi All long time lurker First time post!

I have been using the following code from Ron de Bruin within my routine to zip the active workbook, however, I now need to ensure the resulting zip file is passworded an wonder if anyone can help me with this?

Code:
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

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
 

Some videos you may like

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.

Leith Ross

Well-known Member
Joined
Mar 17, 2008
Messages
1,874
Office Version
  1. 2010
  2. 2007
Platform
  1. Windows
Hello Woody,

You may find my version easier to use and understand. Here is the macro code along with an example of using it. The password is optional.
Code:
' 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 CmdLine As String
    Dim Ext As Long
    Dim FilePath As String
    Dim RetVal As Long
    Dim Path As Long
    Dim ZipName As String
    
      ' If no path is specified use the current directory
        Path = InStrRev(FileName, "\")
        FilePath = IIf(Path = 0, CurDir & "\", "")
    
      ' 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, ".")
        ZipName = FilePath & IIf(Ext = 0, FileName & ".zip", Left(FileName, Ext) & "zip")
    
      ' 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

Example of using the macro:
Code:
Sub ZipTest()


  ZipFile "C:\PF Credits.xls", Password:="123"
  
End Sub
 

Woody

New Member
Joined
Jan 3, 2005
Messages
5
Hi Leith

Thanks for the quick response, I will give your code a go!

Cheers

Woody
 

Klebinho

New Member
Joined
Jan 27, 2017
Messages
1
Hi Leith,

I changed this code above to "seven zip", and the line below is not working. Could you help me with that?

FilePath = ""
CmdLine = "7z a -tzip -p" & Chr$(34) & Password & Chr$(34) & " " & Chr$(34) & ZipName & Chr$(34) & " " & Chr$(34) & FileName & Chr$(34)
RetVal = ShellExecute(0&, "", "7z.exe", CmdLine, FilePath, 1&)
I didn´t get the "0&" at the beggining either the "1&" at the end.

Directly in the CMD this CmdLine works. But when i try in the ShellExecute... the result is "file not Found" (error 2)
 

Watch MrExcel Video

Forum statistics

Threads
1,122,232
Messages
5,594,962
Members
413,954
Latest member
mrsandy

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top