Automatic Removal of Attachments in Outlook Folders

I'd been running out of space on my laptop's hardrive (Windows XP incarnation), so had to clean up a lot of old files. One of the bigger space hogs are the Outlook folders (*.ost and *.pst). I discovered that my SentMail folder had an awful lot of attachments, but short of opening each sent mail and deleting the attachments one-by-one, there seemed no method of en-mass attachment removal.

One VB macro later, there was a method. One problem you might find in running macros in Outlook is that the security level does not permit the execution of unsigned macros. If you get a message like "The macros in this project are disabled.", then go to Tools > Macro > Security and set the Security Level to Medium or Low. Then restart Outlook.

Here's the VB code for the macro. It operates against the currently displayed folder. If this folder doesn't contain mail items, it issues an error message and exits.

Sub DeleteAttachments()
Dim action As Integer
Dim theType As OlItemType
Set theOlApp = CreateObject("Outlook.Application")
Set theOlExp = theOlApp.ActiveExplorer
Set theCurrentFolder = theOlExp.CurrentFolder
theType = theCurrentFolder.DefaultItemType
If theType <> olMailItem Then
    MsgBox ("The current folder (" + _
            theCurrentFolder.Name + _
            ") does not contain mail items.")
Else
    action = MsgBox("About to delete all attachments for mail in " + _
                    theCurrentFolder.Name + _
                    ".  Are you sure?", 4, "Delete Attachments")
    If action = 6 Then
        Set Items = theCurrentFolder.Items
        cnt = 0
        For Each Item In Items
           Set Attachments = Item.Attachments
           While Attachments.Count > 0
               cnt = cnt + 1
               Attachments(1).Delete
           Wend
        Item.Save
        Next
        MsgBox (Str(cnt) + " Attachments Deleted")
    End If
End If
End Sub

Here's a different flavour of the above macro. This version deletes all attachments for the currently open email. If you like living dangerously, uncomment the theSel.Item(x).Save line. This will ensure the deletion takes place immediately, without the chance to cancel it. This macro is more convenient if you hook it up to a button on the toolbar.

Sub DeleteItemAttachments()
' Delete all attachments for the current item
Dim action As Integer
Dim theType As OlItemType
Set theOlApp = CreateObject("Outlook.Application")
Set theOlExp = theOlApp.ActiveExplorer
Set theCurrentFolder = theOlExp.CurrentFolder
Set theSel = theOlExp.Selection
If theSel.Count > 1 Then
    MsgBox "More than one item is selected.  Action aborted."
Else
    For x = 1 To theSel.Count
        Set Attachments = theSel.Item(x).Attachments
        cnt = 0
        While Attachments.Count > 0
            cnt = cnt + 1
            Attachments(1).Delete
        Wend
        'theSel.Item(x).Save
    Next x
End If
End Sub