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
- Next i
- End If
- Next objMsg
- Set NewobjMsg = Application.CreateItem(olMailItem)
- With NewobjMsg
- .To = "[email protected]"
- .Subject = "Deleted Attachments"
- .BodyFormat = olFormatPlain ' send plain text message
- .Body = msgBody
- End With
- Set NewobjMsg = Nothing
- Set objAttachments = Nothing
- Set objMsg = Nothing
- Set objSelection = Nothing
- Set objOL = Nothing
- End Sub