VBA – Removing attachments from Outlook email

Posted on Friday, July 1st, 2011 at 8:20 pm in

One very powerful aspect of the Microsoft Office Suite of applications is the ability to create Macros and Scripts to perform various processes. This gives those of us who worked in Visual Basic 6 a chance to dust off our skills since the ‘flavor’ of Visual Basic used in the Microsoft Office applications (aptly called Visual Basic for Applications) is essentially the same.

A common request in Outlook is to process mail messages with attachments by removing the attachments and saving them to some specified folder. This can be accomplished with either a macro or a script. The script has an advantage of being something you can put into a rule so any incoming emails are processed automatically. Macros allow you to process only specific emails should you so desire.

My examples below are set to remove external calendar request files (.ICS or ICalendar format) and place them into the folder ‘ICSFiles’ set up in the standard ‘My Documents’ folder.

Public Sub SaveICSAttachments()
' to set this as a script the declaration would be
' Public Sub SaveICSAttachments(objitem As MailItem)
Dim objOL As Outlook.Application
''''''''''''''''''''''''''''''''''''
' the next line removed if set up as a script
Dim objitem As Outlook.MailItem 'Object
'''''''''''''''''''''''''''''''''''
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lCount As Long
Dim sFile As String
Dim sFolderpath As String
Dim sDeletedFiles As String

' Instantiate an Outlook Application object.
Set objOL = Application

Dim objNs As Outlook.NameSpace
Set objNs = objOL.Session
Dim objFolder As Outlook.MAPIFolder

' Get the path to your My Documents folder
sFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next

' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection

' Set the Attachment folder.
' You could check for the existance of the folder and 
' prompt the user if you want
sFolderpath = sFolderpath & "\ICSFiles\"

' Check each selected item for attachments.
'''''''''''''''''''''''''''''''
' Remove loop if used in script (you call script with the item)
For Each objitem In objSelection
'''''''''''''''''''''''''''''''''''''
	' Remove this check if running as a script
	' This code only strips attachments from mail items.
	If objitem.Class = olMail Then
	'''''''''''''''''''''''''''''''''''
		' Get the Attachments collection of the item.

		Set objAttachments = objitem.Attachments
		lCount = objAttachments.Count

		If lCount > 0 Then
			' Since we are removing things from an array, remove
			' from the end going to the beginning
			For i = lCount To 1 Step -1

				' Save attachment before deleting from item.
				sFile = objAttachments.Item(i).FileName
				' only looking for ICS file attachments
				If Right(sFile, 3) = "ics" Then
					' Combine with the path to the Temp folder.
					sFile = sFolderpath & sFile

					' Save the attachment as a file.
					objAttachments.Item(i).SaveAsFile sFile
                                        ' remove attachment
					objAttachments.Item(i).Delete

					'write the save as path to a string to add to the message
					If objitem.BodyFormat <> olFormatHTML Then
						sDeletedFiles = sDeletedFiles & vbCrLf & "<file://" & sFile & ">"
					Else
						sDeletedFiles = sDeletedFiles & "<br>" & "<a href='file://" & sFile & "'>" & sFile & "</a>"
				End If
			Next i
		End If

		' Adds the filename string to the message body and save it
		If objitem.BodyFormat <> olFormatHTML Then
			 objitem.Body = objitem.Body & vbCrLf & "The file(s) were saved to " & sDeletedFiles
		 Else
			 objitem.HTMLBody = objitem.HTMLBody & "<p>" & "The file(s) were saved to " & sDeletedFiles & "</p>"
		 End If
		 ' save the modified email with link to the detached file
		 objitem.Save
	''''''''''''''''''''
	' remove if running as a script
   End If
   '''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''
' remove loop if running as a script
Next
''''''''''''''''''''''''''''''''
ExitSub:

Set objAttachments = Nothing
Set objitem = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

(Sorry for the screwed up code listing but the file link tags are being improperly interpreted by the plugin I use).

This macro was designed to run on Outlook 2007. You will most likely have to change the security settings in Outlook to have it run (and sign the macro or whatever). There is minimal (none) error checking in this code but then I’m not going to do it all for you.

You might also be interested in

Top