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!

 

[Logit]

.
I am not familiar with the goal of your project but here are a few resources that might assist you :

https://stackoverflow.com/questions...xport-workbook-to-password-protected-zip-file

https://www.rondebruin.nl/win/section7.htm

https://www.rondebruin.nl/win/s7/win001.htm

 

[wazzulu1]

Thanks!

 

[wazzulu1]

I can remove the *.xlsb reference so it does not use the Personal.xlsb file, but I still don't see how to reference any other open workbook open other than Personal.xlsb for this code to work.

 

[wazzulu1]

Tried to make some changes, this does not work either

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 Wb As Workbook
    Dim Wb2 As Workbook
    Set Wb = ThisWorkbook


    Dim strDate As String, DefPath As String
    Dim FileNameZip, FileNameXls
    Dim oApp As Object
    Dim FileExtStr As String
    
    For Each Wb2 In Application.Workbooks
    Wb2.Activate


    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
    Next
End Sub

 

[JoeMo]

I haven't looked at your code, but it might help you to know that Thisworkbook refers to the workbook containing the code you are running. If the code is in your PERSONAL.XLSB and you want the code to apply to another workbook when you run it, then make the other workbook active when you run the code and change Thisworkbook to Activeworkbook where appropriate in the code.

 

[wazzulu1]

Hi Joe;

That's what I was trying to do.

 

[Logit]

.
I'll try to lend a hand here but I've never tried to use VBA to zip or unzip files.

The little research reading I've done indicates you must use a ZIP program in conjunction with the VBA. I don't see in your code where you've referenced any
ZIP program ?

There are plenty of references to using 7Zip which is an open source / freeware version. Download



Here is an example VBA macro from Ron de Bruin who is known for his excellence in Excel: https://www.rondebruin.nl/win/s7/win003.htm


If you will use this search line : 7zip password command line for vba you'll get plenty of examples using 7Zip

 

[wazzulu1]

I have one that is being called in by the Windows program I have. It's creating a zip file ok.

The problem I am having is trying to reference the 1st file I opened to zip to be the active workbook, the files I have to send are not xlsm files, they are either xls or xlsx, and I am trying to avoid importing the code into each file. This is why I was trying to run it from the Personal.xlsb file, but it's treating it like the active workbook, so I keep zipping that file, not the data file I first opened.

 

[Logit]

.
I apologize for not being able to follow your macro code. Guess it's too late in the day for my old brain.

In any case, here is a smaller macro I cobbled together using 7Zip. The only reason I used 7Zip is due to the resources
easily available.

Option Explicit


'This macro takes all files (*.xlsx) in folder located at :  "C:\Users\My\Desktop\New folder\"
'Places them into a zip file (using 7Zip) and stores the zip file in a sub-folder named  zip


Edit As Required


Sub zipAll()
Dim strDestFileName, strSourceFileName, str7ZipPath, strCommand, folder As String


folder = "C:\Users\My\Desktop\New folder\"


strDestFileName = folder + "zip\" + Filename + ".zip"
 strSourceFileName = folder + Filename + "*.xlsx"
 str7ZipPath = "C:\Program Files\7-Zip\7z.exe"


 strCommand = str7ZipPath & " a -tzip """ & strDestFileName & """ """ & strSourceFileName & """"
 Shell strCommand
End Sub