RSS Feeds

An example of how to use VBA/COM over Outlook

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