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