Do you hate those pesky people that send you 7Mbyte unzipped attachments
This is a little demo of the power of VBA/COM integration.
At work we suffer from these bizarre Denial of Service attacks – not from hackers but from accountants and other bureaucrats who insist on sending out mega-Workbooks thereby filling your mailbox. I got fed up with then having to drop these attachments onto the desktop, zipping them and then replacing the originals. My companies support people don’t offer or license any nice add-ins to do this for you, so I wrote this sort VBA macro to do the job for me. One click, job done.
This VBA routine walks an Outlook folder hierarchy and ZIPs attachments for files that are older that “nMonthsAged” and larger than “nMinMsgSize”. Any attachments (excluding extensions from “sExcludedExts”) are ZIPped and replaced. Note that you will need to install the command line extension to WINZIP which is a free add-on from www.winzip.com for anyone with a valid Winzip licence. Note that if you haven`t been ZIPing your attachments then running this can reduce your PST size by perhaps 40%, so it is well worth compacting it after running this macro. (You will find this as an advanced option under the folder properties). If you don’t want to get bother by those nasty “do you want to allow these macros?” every time you start up outlook, then you will need to sign then with a trusted certificate. See KB Q217221 which tells you how to use SelfCert to sign this module.
The easiest way to invoke these is to add a couple of macro buttons to your Standard command bar to call these routines.
Attribute VB_Name = "FolderZipPack" Option Explicit Const nMonthsAged As Long = 3 Const nMinMsgSize As Long = 10000 Const sExcludedExts As String = ".ZIP.GIF.PDF.PGP.CAB.GZ.JPG.RAR.PNG" Dim sWZzip As String Dim nProcessed As Long, nBefore As Long, nAfter As Long Dim dCutOff As Date Dim wsh As WshShell, fso As FileSystemObject Sub ZipFolderAttachments() Dim olApp As Outlook.Application Dim olSession As Outlook.NameSpace Dim olStartFolder As Outlook.MAPIFolder Dim strPrompt As String `Initialize Global Variables nProcessed = 0 nBefore = 0 nAfter = 0 dCutOff = DateAdd("m", -3, Now) sWZzip = """" & Environ("ProgramFiles") & "\WinZip\WZZIP.EXE"" -m " Set wsh = CreateObject("Wscript.Shell") Set fso = CreateObject("Scripting.FileSystemObject") ` Get a reference to the Outlook application and session. Set olApp = Application Set olSession = olApp.GetNamespace("MAPI") Set olStartFolder = olSession.PickFolder If olStartFolder Is Nothing Then Exit Sub ProcessFolder olStartFolder MsgBox CStr(nProcessed) & " Attachments were processed." & Chr(10) & _ "Emails reduced from " & CStr(Int(nBefore / 1024)) & _ "K to " & CStr(Int(nAfter / 1024)) & "K" Set wsh = Nothing Set fso = Nothing End Sub Private Sub ProcessFolder(CurrentFolder As Outlook.MAPIFolder) Dim i As Long Dim olNewFolder As Outlook.MAPIFolder, olMail As Outlook.MailItem Debug.Print "Processing " & CurrentFolder.FolderPath ' ' Loop around mails (subject to minimum size and age ) looking for files with attachments ' Then for each process each attachmenet if the extension isn`t already a compressed one ' For i = CurrentFolder.Items.Count To 1 Step -1 If TypeName(CurrentFolder.Items(i)) = "MailItem" Then Set olMail = CurrentFolder.Items(i) ZipMsg olMail End If Next i ' Loop through and search each subfolder of the current folder. For Each olNewFolder In CurrentFolder.Folders If olNewFolder.Name <> "Deleted Items" Then ProcessFolder olNewFolder End If Next End Sub ' ' Variant which ZIPs the attachments in one or more Messages selected in the ' Explorer Pail (usually with Preview on) ' Sub ZipSelectedAttachments() Dim olExp As Outlook.Explorer, olSel As Outlook.Selection Dim olMail As Outlook.MailItem Dim i As Long nProcessed = 0 nBefore = 0 nAfter = 0 dCutOff = Now sWZzip = """" & Environ("ProgramFiles") & "\WinZip\WZZIP.EXE"" -m " Set wsh = CreateObject("Wscript.Shell") Set fso = CreateObject("Scripting.FileSystemObject") Set olExp = Application.ActiveExplorer Set olSel = olExp.Selection For i = 1 To olSel.Count If TypeName(olSel.Item(i)) = "MailItem" Then Set olMail = olSel.Item(i) ZipMsg olMail End If Next i MsgBox CStr(nProcessed) & " Attachments were processed." & Chr(10) & _ "Emails reduced from " & CStr(Int(nBefore / 1024)) & _ "K to " & CStr(Int(nAfter / 1024)) & "K" Set wsh = Nothing Set fso = Nothing End Sub Private Sub ZipMsg(olMail As Outlook.MailItem) Dim olAtt As Outlook.Attachment Dim j As Long, pos As Long, stat As Long, update As Boolean Dim nMsgSize As Long, oldSize As Long Dim sFile As String, sName As String, sExt As String, lExt As Long Dim sWkFile As String, sWkZip As String nMsgSize = olMail.Size If olMail.Attachments.Count > 0 And _ olMail.Size > nMinMsgSize And _ dCutOff > olMail.ReceivedTime Then update = False Debug.Print olMail.Subject, olMail.Attachments.Count, olMail.ReceivedTime For j = olMail.Attachments.Count To 1 Step -1 Set olAtt = olMail.Attachments.Item(j) If olAtt.Type = olByValue Then sFile = olAtt.FileName Else sFile = "Really OLE.ZIP" End If lExt = InStrRev(sFile, ".") sName = IIf(lExt = 0, sFile, Left(sFile, lExt - 1)) sExt = IIf(lExt = 0, "", sExt = Mid(sFile, lExt + 1)) If lExt = 0 Or _ InStr(1, sExcludedExts, UCase(sExt)) = 0 Then ' ' Save the attachment to %TEMP% and compress it. ' Then replace the attachment with the compressed version. ' A WZZIP subprocess is spawned to do the compression. The WSH ' run method is used do to this, because it is synchronous. ' sWkFile = Environ("TEMP") & "\" & sFile sWkZip = Environ("TEMP") & "\" & sName & ".ZIP" olAtt.SaveAsFile sWkFile oldSize = fso.GetFile(sWkFile).Size pos = olAtt.Position ' ' A zero pos indicates a hidden attachment except in the case ' Plain and HMTL msgs ' If pos = 0 And _ (olMail.BodyFormat = olFormatHTML) Or _ (olMail.BodyFormat = olFormatPlain) Then pos = 1 stat = wsh.Run(sWZzip & """" & sWkZip & """ """ & sWkFile & """", 7, True) If fso.GetFile(sWkZip).Size < oldSize Then Debug.Print " ", olAtt.FileName, olAtt.Position, "ZIP status = " & stat olAtt.Delete olMail.Attachments.Add sWkZip, olByValue, pos nProcessed = nProcessed + 1 update = True End If fso.DeleteFile (sWkZip) End If Next j If update Then olMail.Save nBefore = nBefore + nMsgSize nAfter = nAfter + olMail.Size End If End If End Sub