Removing attachments from your emails will reduce your PST file size and network footprint, but now you're left with attachments and no way to reference where they came from.
We need a way to strip attachments from a set of emails, but hyperlink to them so that we can retrieve or reference the files later, so (surprise!) we'll use VBA, both as an event handler and a one-off procedure to do this.
If you choose to use the event handler, you'll still need to run the one-off procedure on any folder that already has emails with attachments.
Currently both procedures are looking for the following file types:
- doc
- xls
- ppt
- mdb
The event handler checks if an incoming item is an email message. If so, it checks the number of attachments. If there are attachments, and they match one of the file types above, the attachments are removed and a link to the saved file is placed in the body of the message.
Note that this will only work with HTML formatted messages, since the hyperlink requires that the email be formatted as HTML. Otherwise, the body is updated with a text link indicating the folder and filename (you can always copy and paste the folder path into Windows Explorer). If you don't care about damaging the body of an email, you can always convert the email to HTML before adding the hyperlink. Keep in mind this will ruin all the formatting of the existing message.
You can also get more creative with the filename, such as adding the message subject or received time to it.
Event Handler
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Set olApp = GetOutlookApp
Set olNS = GetNS(olApp)
Set Items = GetItems(olNS, olFolderInbox)
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim fileExts() As Variant
Dim Msg As Outlook.MailItem
Dim atts As Outlook.Attachments
Dim att As Outlook.Attachment
Dim filePath As String
Dim fileDisplayName As String
Dim folder As String
Dim i As Long
' set up save folder
' change this to whatever you want
folder = Environ("userprofile") & "\Desktop\"
' parse file extensions, edit to taste
fileExts = Array("doc", "xls", "ppt", "mdb", "pdf")
' only act on mail items
If TypeName(item) <> "MailItem" Then GoTo ProgramExit
Set Msg = item
Set atts = Msg.Attachments
' loop through attachments, if the file extension matches one of the
' specified file types, save it to the given folder
For i = atts.Count To 1 Step -1
fileDisplayName = atts.item(i).DisplayName
If IsInArray(fileExts(), GetFileType(fileDisplayName)) Then
filePath = folder & fileDisplayName
With atts.item(i)
.SaveAsFile filePath
.Delete
End With
' update message body with a link to the saved file
' HTMLBody will trigger security prompt
With Msg
If Msg.BodyFormat = olFormatHTML Then
Msg.HTMLBody = Msg.HTMLBody & _
"<p>Attachment: " & _
"<a href=" & Chr(34) & filePath & _
Chr(34) & ">" & fileDisplayName & _
"</a>" & " was saved to: " & _
folder & "</p>"
Else
Msg.Body = Msg.Body & vbCrLf & "Attachment: " & _
fileDisplayName & " was saved to: " & folder
End If
End With
End If
Next i
' save the msg to update it
Msg.Save
' comment this line if you don't want a msgbox
' interrupting you every time a matching email
' comes in
MsgBox "File attachments were extracted from your incoming email. See email body for links."
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.number & " - " & Err.Description
Resume ProgramExit
End Sub
Function GetFileType(ByVal fileName As String) As String
' get file extension
GetFileType = Mid$(fileName, InStrRev(fileName, ".") + 1, Len(fileName))
End Function
Function IsInArray(arr() As Variant, valueToCheck As Variant) As Boolean
' returns true if value is found in array
IsInArray = (UBound(Filter(arr, valueToCheck)) > -1)
End Function
Function GetOutlookApp() As Outlook.Application
' returns reference to native Application object
Set GetOutlookApp = Outlook.Application
End Function
Function GetNS(ByRef app As Outlook.Application) As Outlook.NameSpace
Set GetNS = app.GetNamespace("MAPI")
End Function
Function GetItems(olNS As Outlook.NameSpace, folder As OlDefaultFolders) As Outlook.Items
Set GetItems = olNS.GetDefaultFolder(folder).Items
End Function
One-off and loop procedures
The next two procedures are used when you want to manually scrub an email of attachments, while adding a link to the saved file to the body of the email. The only difference is that the first one will work on a selected or open email, while the second one will loop through a given folder and strip attachments from all the emails in that folder.
Sub StripAttachmentsSingleEmail()
' strip attachments from one selected
' or open email
On Error GoTo ErrorHandler
Dim msg As Outlook.MailItem
Dim atts As Outlook.Attachments
Dim fileExts() As Variant
Dim folder As String
Dim i As Long
Dim fileDisplayName As String
Dim filePath As String
Set msg = GetMailItem
If msg Is Nothing Then
MsgBox ("Select or open an email first.")
GoTo ProgramExit
End If
' set up save folder
' change this to whatever you want
folder = Environ("userprofile") & "\Desktop\"
' file extensions
fileExts = Array("doc", "xls", "ppt", "mdb", "pdf")
Set atts = msg.Attachments
' loop through attachments, if the file extension matches one of the
' specified file types, save it to the given folder
For i = atts.Count To 1 Step -1
fileDisplayName = atts.item(i).DisplayName
If IsInArray(fileExts(), GetFileType(fileDisplayName)) Then
filePath = folder & fileDisplayName
With atts.item(i)
.SaveAsFile filePath
.Delete
End With
' optional: update message body with
' a link to the saved file
' HTMLBody will trigger security prompt
With msg
If msg.BodyFormat = olFormatHTML Then
msg.HTMLBody = msg.HTMLBody & _
"<p>Attachment: " & _
"<a href=" & Chr(34) & filePath & _
Chr(34) & ">" & fileDisplayName & _
"</a>" & " was saved to: " & _
folder & "</p>"
Else
msg.Body = msg.Body & vbCrLf & "Attachment: " & _
fileDisplayName & " was saved to: " & folder
End If
End With
End If
Next i
' save the msg to update it
msg.Save
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.number & " - " & Err.Description
Resume ProgramExit
End Sub
Function IsInArray(arr() As Variant, valueToCheck As Variant) As Boolean
' returns true if value is found in array
IsInArray = (UBound(Filter(arr, valueToCheck)) > -1)
End Function
Function GetMailItem() As Outlook.MailItem
On Error Resume Next
Select Case TypeName(Application.ActiveWindow)
Case "Explorer"
If TypeName(ActiveExplorer.Selection.item(1)) = "MailItem" Then
Set GetMailItem = ActiveExplorer.Selection.item(1)
End If
Case "Inspector"
If TypeName(ActiveInspector.currentItem) = "MailItem" Then
Set GetMailItem = ActiveInspector.currentItem
End If
End Select
On Error GoTo 0
End Function
Loop through a folder, remove attachments and add hyperlink
Sub StripAttachmentsLoop()
' loop through folder
On Error GoTo ErrorHandler
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim itms As Outlook.Items
Dim msg As Outlook.MailItem
Dim atts As Outlook.Attachments
Dim fileExts() As Variant
Dim folder As String
Dim i As Long
Dim fileDisplayName As String
Dim filePath As String
Set olApp = GetOutlookApp
Set olNS = GetNS(olApp)
' or whatever folder you want
Set itms = GetItems(olNS, olFolderInbox)
If itms.Count = 0 Then
MsgBox ("No items found in that folder.")
GoTo ProgramExit
End If
' set up save folder
' change this to whatever you want
folder = Environ("userprofile") & "\Desktop\"
' file extensions
fileExts = Array("doc", "xls", "ppt", "mdb", "pdf")
For Each msg In itms
Set atts = msg.Attachments
' loop through attachments, if the file extension matches one of the
' specified file types, save it to the given folder
For i = atts.Count To 1 Step -1
fileDisplayName = atts.item(i).DisplayName
If IsInArray(fileExts(), GetFileType(fileDisplayName)) Then
filePath = folder & fileDisplayName
With atts.item(i)
.SaveAsFile filePath
.Delete
End With
' optional: update message body with
' a link to the saved file
' HTMLBody will trigger security prompt
With msg
If msg.BodyFormat = olFormatHTML Then
msg.HTMLBody = msg.HTMLBody & _
"<p>Attachment: " & _
"<a href=" & Chr(34) & filePath & _
Chr(34) & ">" & fileDisplayName & _
"</a>" & " was saved to: " & _
folder & "</p>"
Else
msg.Body = msg.Body & vbCrLf & "Attachment: " & _
fileDisplayName & " was saved to: " & folder
End If
' save the msg to update it
msg.Save
End With
End If
Next i
Next msg
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.number & " - " & Err.Description
Resume ProgramExit
End Sub
Function IsInArray(arr() As Variant, valueToCheck As Variant) As Boolean
' returns true if value is found in array
IsInArray = (UBound(Filter(arr, valueToCheck)) > -1)
End Function
Function GetOutlookApp() As Outlook.Application
' returns reference to native Application object
Set GetOutlookApp = Outlook.Application
End Function
Function GetNS(ByRef app As Outlook.Application) As Outlook.NameSpace
Set GetNS = app.GetNamespace("MAPI")
End Function
Function GetItems(olNS As Outlook.NameSpace, folder As OlDefaultFolders) As Outlook.Items
Set GetItems = olNS.GetDefaultFolder(folder).Items
End Function
About JP
2 Comment(s) on Strip selected attachments and save to folder:
Hi JP,
Have been very impressed with these posts on email management and could really use this code to strip mail and add link to file. I am having errors with GetFileType and not sure why? Are you able to advise how to resolve?
Tim Buckingham
codeforexcelandoutlook fanboy!
Tim,
It might be that you don't have the function. Here it is. If you add the function and it still doesn't work, set a breakpoint and try stepping through it.