You are here:

Excel/Excel 2007 Macro to Zip active worksheet and send via outlook

Advertisement


Question
I have an excel macro that zips the active worksheet and sends the attachment via outlook. The issue that I have is I am trying to password protect the zip file once it has completed. I have attached the macro below and hope you can guide me with the password setup.



Sub NewZip(sPath)
'Create empty Zip File
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 Function
End Sub

__________________________________________________________________
SUB ZipFile()

Dim strDate As String, DefPath As String, strbody As String
   Dim oApp As Object, OutApp As Object, OutMail As Object
   Dim FileNameZip, FileNameXls
   Dim FileExtStr As String

   DefPath = Application.DefaultFilePath
   If Right(DefPath, 1) <> "\" Then
       DefPath = DefPath & "\"
   End If


'Folder where report is held
DefPath = "file path on C drive"


FName = "report name.xlsx"
'My text file.txt"



   '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

   'formats the date
   strDate = Format(Now, " yyyy-mm-dd h-mm-ss")

  'Name of the Zip File
   FileNameZip = DefPath & Left(ActiveWorkbook.Name, _
   Len(ActiveWorkbook.Name) - Len(FileExtStr)) & strDate & ".zip"
   
  
  'Name of the file
   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


       'Create the mail
       Set OutApp = CreateObject("Outlook.Application")
       Set OutMail = OutApp.CreateItem(0)
       strbody = "Hello there; Here is today's Report          "


       On Error Resume Next
       With OutMail
         .To = "" 'CHANGE TO YOUR ADDRESS TO TEST
         .CC = ""
         .BCC = ""
         .Subject = "Report Test"
         .Body = strbody
         .Attachments.Add FileNameZip
         .Display   'or use .Send
         End With
       On Error GoTo 0

       'Delete the temporary Excel file and Zip file you send
'        Kill FileNameZip
'        Kill FileNameXls
   Else
       MsgBox "FileNameZip or/and FileNameXls exist"
   End If
End Sub

Answer
As far as I know you cannot do this with the built-in Windows Zip.
You could do this with a third party program like 7Zip or WinZip, something like:

strDestFileName = "c:\temp\TestZipFile.zip"
strSourceFileName = "c:\temp\test.pdf"
str7ZipPath = "C:\Program Files\7-Zip\7z.exe"
strPassword = "YourPassword"

strCommand = str7ZipPath & " -p" & strPassword & " a -tzip """ & strDestFileName & """ """ & strSourceFileName & """"
Shell strCommand

You can get 7zip at http://7-zip.org/
About Excel
This topic answers questions related to Microsoft Excel spreadsheet (or workbook) stand-alone or Mircrosoft Office Excel including Excel 2003, Excel 2007, Office 2000, and Office XP. You can get Excel help on Excel formulas(or functions), Excell macros, charting in Excel, advanced features, and the general use of Excel. This does not provide a general Excel tutorial nor the basics of using a spreadsheet. It provides specific answers to using Microsoft Excel only. If you do not see your Excel question answered in this area then please ask an Excel question here

Excel

All Answers


Answers by Expert:


Ask Experts

Volunteer


Gyula Gulyas

Expertise

I can answer most questions related to macros, worksheet functions, VBA, Office automation (calling/using other MS Office programs) and geocoding using Google Maps. I have 10 years experience using and programming in MS Excel and other office applications. I have extensive experience linking and using DLLs in Excel.

Experience

Macros, worksheet functions, VBA, linking of DLLs and Office automation, geocoding using Google Maps.

©2016 About.com. All rights reserved.