How can I password protect the zip folder in VBA? - excel

Question

I want to password protect the zip folder not the files in zip folder using VBA.
for example: if there is folder test.zip and there is file test.xlsx in it. I want to have a password on folder test.zip. Can someone help? Will be highly appreciated. Thanks

Answer 1

This procedure accepts an argument named NewFolder, which represents the folder to which the user is trying to switch. If this folder’s name is Confidential, the procedure asks the user to enter the password. If the password doesn’t match, the Cancel argument is set to True, which means the folder isn’t displayed.
Hope this will help you:
Sub zip_activeworkbook()
Dim strDate As String, DefPath As String
Dim FileNameZip, FileNameXls
Dim oApp As Object
If ActiveWorkbook Is Nothing Then Exit Sub
DefPath = ActiveWorkbook.Path
If Len(DefPath) = 0 Then
msgbox "Please Save activeworkbook before zipping" & Space(12), vbInformation, "zipping"
Exit Sub
End If
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
'Create date/time string and the temporary xls and zip file name
strDate = Format(Now, " dd-mmm-yy h-mm-ss")
FileNameZip = DefPath & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & strDate & ".zip"
FileNameXls = DefPath & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & strDate & ".xls"
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 "completed zipped : " & vbNewLine & FileNameZip, vbInformation, "zipping"
Else
msgbox "FileNameZip or/and FileNameXls exist", vbInformation, "zipping"
End If
End Sub
Private 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
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.
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
Example of using the macro:
Sub ZipTest()
ZipFile "C:\PF Credits.xls", Password:="123"
End Sub