Help with VBA Code to make Zip File

[wazzulu1]

Hi;

The code below will make a zip file out of the active workbook being used. I am trying to use it to make zip files for the Excel files I need to send to users, and would like to add a password when creating the zip file within the code itself, not by a prompt (hundreds of files to send).

However, because I am not placing the code within each file I am sending (xlsx, Excel 2010), I am running this from my Personal.xlsb, it's making a copy of it, rather than the Workbook I have open.

Was looking for a way to ignore the Personal.xlsb file, and target the open Workbook file, plus add a password to the created zip file when compression has completed.

Sub NewZip(sPath)    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


Sub Zip_ActiveWorkbook()




 Dim strDate As String, DefPath As String
    Dim FileNameZip, FileNameXls
    Dim oApp As Object
    Dim FileExtStr As String


    DefPath = "C:\Zips\"    '<< 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


Appreciate any insight given, Thanks!

 

[wazzulu1]

I appreciate what was shared, but we have to send files to different individuals, so using this places us in the same position as generating them and zipping them individually, which is our current position.

 

[Logit]

.
Do you need to Zip each file independently ?

Or, can you zip all files together in one package ?

In other words, if there are ten files in a folder, can you zip them all together as a single zip ?

 

[wazzulu1]

They need to be independently zipped, and distributed to different recipients.

 

[wazzulu1]

This might help, but I am not sure how to add it to this code:

'Add -s like this -sYourPassWordHere if you want to add a password to the files in the zip        '        Password = """TopSecret"""    'Do not remove the six quotes
        '        ShellStr = PathZipProgram & "Winzip32.exe -min -a -r -s" & Password _
                 '                 & " " & Chr(34) & NameZipFile & Chr(34) _
                 '                 & " " & Chr(34) & FolderName & "*.*" & Chr(34)

 

[wazzulu1]

Trying to add this:

'Add -s like this -sYourPassWordHere if you want to add a password to the files in the zip        '        Password = """TopSecret"""    'Do not remove the six quotes
        '        ShellStr = PathZipProgram & "Winzip32.exe -min -a -r -s" & Password _
                 '                 & " " & Chr(34) & NameZipFile & Chr(34) _
                 '                 & " " & Chr(34) & FolderName & "*.*" & Chr(34)

To 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