'Removing Outlook Email Attachments and Replace Them with a Links to a Saved Location
'
'   1. Removing attachments of selected messages (one or many) and saving them to a Local/Mapped drive location
'   2. Adding a link to the bottom of each email to the saved attachment files.
'
' How to use it:
'
'   1. Add Developer Tools to the Outlook Ribbon:
'   2. Set Macro Security to “Prompt for All”
'  	3. Create a New Macro. Title it “SaveAttachmentsSelected” (You open the window the type the name and click “Create”)
'   4. Replace everything in the window that appears with the contents of the code below.
'   5. Click save and close the VBA editor.
'   6. Add a “Quick Access Toolbar” link to the Macro
'   7. Find an email to use as a test (make sure it’s something you won’t miss in case there is a problem.)
'   8. Select the email, then click the Macro icon in the Toolbar
'   9. Check out the body of the email….it should have links to the attachment(s) at the very bottom of the email message. Make sure they work.
'   10. To do multiple emails, just select multiple items.
'
'Be patient with this method. When you select a large number of emails just sit back and give Outlook time to crank through everything. Start with small batches so you can get a feel for how it works and the time it takes to save the files.
'
'https://charlesulrich.blogspot.com/2013/09/removing-outlook-email-attachments-and.html

Sub SaveAttachmentsSelected()
Dim filesys, newfolder
Dim objOL As Outlook.Application
Dim pobjMsg As Outlook.MailItem 'Object
Dim objSelection As Outlook.Selection
Dim strFolderpath As String

'SETTINGS HERE AND THERE IS ANOTHER SET FURTHER DOWN
'I had issues using the HOMEDRIVE environmental variable so I hard coded this to the AD user drive.
'Feel free to try the other options as they might work for you
strFolderpath = "U:"

' Get the path to your Home Direcorty folder
'strFolderpath = Environ("HOMEDRIVE")

' The following line sets the base location as My Documents
'strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next

strFolderpath = strFolderpath & "\Outlook_Attachments\"

'Create Base Directory
Set filesys = CreateObject("Scripting.FileSystemObject")
If Not filesys.FolderExists(strFolderpath) Then
   newfolder = filesys.CreateFolder(strFolderpath)
End If

' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")

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

For Each pobjMsg In objSelection
SaveAttachments_Parameter pobjMsg
Next

ExitSub:

Set pobjMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

Public Sub SaveAttachments_Parameter(objMsg As MailItem)
Dim filesys, newfolder, colProcessEnvVars
Dim objAttachments As Outlook.Attachments
Dim i As Long
Dim lngCount As Long
Dim HomeDir As String
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String

'SETTINGS HERE AND THERE IS ANOTHER SET ABOVE
'I had issues using the HOMEDRIVE environmental variable so I hard coded this to the AD user drive.
'Feel free to try the other options as they might work for you
strFolderpath = "U:"

' Get the path to your Home Direcorty folder
'strFolderpath = Environ("HOMEDRIVE")

' The following line sets the base location as My Documents
'strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)

On Error Resume Next

' Set/Create the Attachment folder. 
' This Adds a folder structure which places attachements in folders based on Year and Month
strFolderpath = strFolderpath & "\Outlook_Attachments\" & Format(objMsg.ReceivedTime, "yyyy-MM") & "\"

Set filesys = CreateObject("Scripting.FileSystemObject")
If Not filesys.FolderExists(strFolderpath) Then
   newfolder = filesys.CreateFolder(strFolderpath)
End If

' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count

If lngCount > 0 Then

' We need to 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

' Save attachment before deleting from item.
' Get the file name.
strFile = objAttachments.Item(i).FileName

' Combine with the path to the Temp folder.
' This Creates a filename which includes the senders name, the date the email was sent, and the filename.
strFile = strFolderpath & objMsg.SenderName & "_" & Format(objMsg.ReceivedTime, "yyyy-MM-dd-h-mm-ss") & "_" & i & "_" & strFile

' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile

' Delete the attachment.
objAttachments.Item(i).Delete

'write the save as path to a string to add to the message
'check for html and use html tags in link
If objMsg.BodyFormat <> olFormatHTML Then
strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
Else
strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & strFile & "'>" & strFile & "</a>"
End If
Next i
End If

' Adds the filename string to the message body and save it
' Check for HTML body
If objMsg.BodyFormat <> olFormatHTML Then
objMsg.Body = objMsg.Body & vbCrLf & vbCrLf & "The attachment(s) were saved to " & strDeletedFiles
Else
objMsg.HTMLBody = objMsg.HTMLBody & "<br>" & "<br>" & "The attachment(s) were saved to " & strDeletedFiles & ""
End If
objMsg.Save
ExitSub:

Set objAttachments = Nothing
Set objMsg = Nothing
Set objOL = Nothing
End Sub