Help with VBA Code to make Zip File

wazzulu1

Board Regular
Joined
Oct 4, 2006
Messages
164
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.

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

Board Regular
Joined
Oct 4, 2006
Messages
164
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.
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple

Logit

Well-known Member
Joined
Aug 31, 2016
Messages
4,013
.
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 ?
 
Last edited:

wazzulu1

Board Regular
Joined
Oct 4, 2006
Messages
164
They need to be independently zipped, and distributed to different recipients.
 

wazzulu1

Board Regular
Joined
Oct 4, 2006
Messages
164
This might help, but I am not sure how to add it to this code:

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

Board Regular
Joined
Oct 4, 2006
Messages
164
Trying to add 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)

To 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
 

Watch MrExcel Video

Forum statistics

Threads
1,130,163
Messages
5,640,519
Members
417,149
Latest member
drbro

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