Zip outgoing attachments
July 23, 2010 • JP • 3 Comments • Rate This Article
• Links to this article
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.
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
Randomize
tempFolder = Environ("temp") & "\temp" & Rnd & "\"
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). 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.
IsMail = (TypeName(itm) = "MailItem")
End Function
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
Outlook ·
Rate This Article:
(No Ratings Yet)
Loading ...What now?
Subscribe To The Blog
Email This Article
Follow Me On Twitter
My Facebook Page
Or just keep reading:
I'm just an average guy who writes VBA code for a living. This is my personal blog. Excel and Outlook are my thing, with a sprinkle of Access and Word here and there. Follow this space if you want to learn more about VBA. Keep Reading »
Previous Post: Delete duplicate contacts in Outlook using VBA
Next Post: Q2 2010 Stats
Thanks so much for the code.
How would you modify it to make sure only attachements of a certain size get zipped ?
Another comment, I think you have to change this portion of the code :
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
Randomize
tempFolder = Environ("temp") & "\temp" & Rnd & "\"
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
to :
If attachmentsCount > 0 Then
Randomize
tempFolder = Environ("temp") & "\temp" & Rnd & "\"
If Not Len(Dir(tempFolder)) > 0 Then
MkDir tempFolder
End If
' 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
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
Elsehow the loop creates a new temp folder for every attachement, so the last line would only zip the last attachement, not the previous ones.
I'll keep you posted as I cannot make it run on my machine.
This is the part of the code that does not work for me :
'Copy the files to the compressed folder
ShellApp.NameSpace(ZipFilename).CopyHere ShellApp.NameSpace(folder).Items
Just can't figure out why.
Error message is 91.
Everything works fine until the code has to copy the files into the newly created zip file (which is indeed created).