Zip outgoing attachments

Edouard asks for some code that will automatically archive attachments on outgoing emails. Let's start with the code found at Saving Compressed Attachments and go from there.

We'll also need some help from Ron de Bruin and his code to zip files using VBA.

The Application_ItemSend Event

This Application-level event fires whenever any item is sent from Outlook. We'll use it to check any outgoing items to see if they are emails with attachments. If so, any unzipped attachments will be archived and re-attached to the email.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

  On Error GoTo ErrorHandler

  Dim msg As Outlook.MailItem
  Dim msgAttachments As Outlook.Attachments
  Dim attachmentsCount As Long
  Dim i As Long
  Dim tempFolder As String
  Dim zipFileAttachment As String

  ' check if it's an email
  If IsMail(Item) Then
    Set msg = Item
    ' check if there are attachments
    Set msgAttachments = GetAttachmentsColl(msg)
    attachmentsCount = msgAttachments.Count

    If attachmentsCount > 0 Then
      ' loop through attachments
      For i = attachmentsCount To 1 Step -1
        ' look for non-zipped files
        If Not IsArchive(msgAttachments.Item(i)) Then
          ' save to temp folder, create if nonexistent
          tempFolder = Environ("temp") & "\temp\unzippedFiles\"
          If Not Len(Dir(tempFolder)) > 0 Then
            MkDir tempFolder
          End If

          msgAttachments.Item(i).SaveAsFile tempFolder & msgAttachments.Item(i).fileName
          ' remove from email
          msgAttachments.Item(i).Delete
        End If
      Next i

      ' go through temp folder, zip all files there and attach back to email
      zipFileAttachment = ZipFiles(tempFolder)

      ' add zip file back to message
      msgAttachments.Add zipFileAttachment
    End If
  End If

ProgramExit:
  On Error Resume Next
  Kill tempFolder
  Exit Sub
ErrorHandler:
  MsgBox Err.number & " - " & Err.Description
  Resume ProgramExit
End Sub

Put this code in your ThisOutlookSession module (Where do I put my Outlook code?) and restart Outlook. Go back to the VB IDE and set a breakpoint on the first line, then send an email with an attachment and watch it work!

The first thing we do is check if the given item is an email. If so, we grab the attachments collection using GetAttachmentsColl. If there are attachments, we'll loop through the collection and check each one. The IsArchive function checks if a given attachment matches a pre-determined list of archive types (zip, rar). Add others if you wish.

If a non-archived file is found attached to the email, a temporary folder is created one level below the temp folder. The folder has a random number in it to severely limit the possibility of duplication (although we do delete it when the macro ends). I use a made-up folder name. The non-archived file is saved to the temp folder and removed as an attachment from the email.

The files in the temp folder are zipped and then the zip file is attached to the email. The temp folder (and all the files in it) are deleted.

Note that we loop backwards because we may be deleting attachments.

Additional Functions

You'll also need these functions in order for the event handler to work.

Function GetAttachmentsColl(itm As Object) As Outlook.Attachments
  Select Case itm.Class
  Case olAppointment, olContact, olDocument, olMail, _
       olMeetingRequest, olPost, olReport, olTask, olTaskRequestAccept, _
       olTaskRequestDecline, olTaskRequest, olTaskRequestUpdate
    Set GetAttachmentsColl = itm.Attachments
  End Select
End Function

Function IsArchive(attachFileName As String) As Boolean
Dim archiveTypes() As String
Dim fileExt As String

  archiveTypes = Split("ZIP, RAR", ",")
  ' get file extension
  fileExt = UCase$(GetFileType(attachFileName))
  If UBound(Filter(archiveTypes, fileExt)) > -1 Then
    IsArchive = True
  End If
End Function

Function GetFileType(ByVal fileName As String) As String
' get file extension
  GetFileType = Mid$(fileName, InStrRev(fileName, ".") + 1, Len(fileName))
End Function

Function ZipFiles(folder As Variant, Optional fileName As String = "files") As String
' http://www.rondebruin.nl/windowsxpzip.htm

Dim ZipFilename As Variant
Dim folderName As Variant
Dim ShellApp As Object
Dim tempFolder As Variant

Const ZIP_FILE_EXTENSION As String = ".zip"

  ' create filename, check for trailing slash
  tempFolder = Environ("temp") & "\"

  ZipFilename = tempFolder & fileName & ZIP_FILE_EXTENSION

  'Create empty Zip File
  NewZip (ZipFilename)

  Set ShellApp = CreateObject("Shell.Application")

  'Copy the files to the compressed folder
  ShellApp.NameSpace(ZipFilename).CopyHere ShellApp.NameSpace(folder).Items

  'Keep script waiting until Compressing is done
  On Error Resume Next
  Do Until ShellApp.NameSpace(ZipFilename).Items.Count = _
     ShellApp.NameSpace(folder).Items.Count
    Application.Wait (Now + TimeValue("0:00:01"))
  Loop
  On Error GoTo 0

  ZipFiles = ZipFilename

End Function

Sub NewZip(sPath)
' http://www.rondebruin.nl/windowsxpzip.htm
'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

IsMail, may be found on the Utility Functions page.