I have taken this code from online somewhere and cannot remember where.
I have way too many emails at work and because of the system set up, I am limited in what I can create to archive older emails.
I don't want to delete any emails but thought that I could reduce the size of my mailbox by removing all attachments over a certain size, saving them in one location and creating a log of where each attachment came from so that I can easily reference back (as to the best of my knowledge when you remove an attachment it removes all trace of it from the email).
I have read online that you can use a rule to do this but it doesn't seem possible on my work system. I am also using Outlook 2010.
So far, this is the code that I am using. The code itself works in that it copies all attachments from the selected emails and saves them in my chosen folder. However, it only deletes the attachments from the first email that it cycles through- not all of the emails. It even works if the first email has 1 or multiple attachments but as soon as it loops to the second email, it stops deleting the attachments.
Aware that I can probably do something more elegant to create the audit log so any advice on that would also be appreciated.
Thank you in advance
Tom
Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim NewobjMsg As MailItem
Dim msgBody As String
msgBody = ""
strFolderpath = "C:\Documents"
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' The attachment folder needs to exist
' You can change this to another folder name of your choice
' Set the Attachment folder.
strFolderpath = strFolderpath & "\Email Attachments\"
' Check each selected item for attachments.
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
' Use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Get the file name.
strFile = objAttachments.Item(i).FileName
' Create a string for email to be sent with Subject and File Name
msgBody = msgBody & objMsg.Subject & "_fname_" & strFile & vbNewLine
' Combine with the path to the Temp folder.
strFile = strFolderpath & strFile
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
' Delete the attachment
objAttachments.Item(i).Delete
Next i
End If
Next objMsg
ExitSub:
Set NewobjMsg = Application.CreateItem(olMailItem)
With NewobjMsg
.To = "[email protected]"
.Subject = "Deleted Attachments"
.BodyFormat = olFormatPlain ' send plain text message
.Body = msgBody
.Display
End With
Set NewobjMsg = Nothing
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub