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
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