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 myItem.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 mail item toolbar.

Sub DeleteOpenItemAttachments()
' Delete all attachments in the currently open email
    Dim myinspector As Outlook.Inspector
    Dim myItem As Outlook.MailItem
    
    Set myinspector = Application.ActiveInspector
    Set myItem = myinspector.CurrentItem
    Set Attachments = myItem.Attachments
    While Attachments.Count > 0
        Attachments(1).Delete
    Wend
    'Don't save changes (leave for the user)
    'myItem.Save
End Sub