Passwording zip file via vba

[Woody]

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?

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

 

[Leith Ross]

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.

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

Sub ZipTest()


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

 

[Woody]

Hi Leith

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

Cheers

Woody

 

[Klebinho]

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)