Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim pobjMsg As Outlook.MailItem 'Object
Dim objSelection As Outlook.Selection
 
' Get the path to your My Documents folder
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
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
 
For Each pobjMsg In objSelection
SaveAttachments_Parameter pobjMsg
Next
 
ExitSub:
 
Set pobjMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
 
Sub SaveAttachments_Parameter(objMsg As MailItem)
Dim objAttachments As Outlook.Attachments
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
 
' Get the path to your My Documents folder
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next
 
' Set the Attachment folder.
strFolderpath = strFolderpath & "\OLAttachments\"
 
' 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.
strFile = strFolderpath & objMsg.SenderName & "." & Format(objMsg.ReceivedTime, "yyyy-MM-dd h-mm-ss") & "." & 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 & "<br>" & "<a href='file://" & strFile & "'>" & strFile & "</a>"
                  Else
                   strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
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 & _
"The file(s) were saved to " & strDeletedFiles
Else
objMsg.HTMLBody = objMsg.HTMLBody & "" & _
"The file(s) were saved to " & strDeletedFiles & ""
End If
objMsg.Save
ExitSub:
 
Set objAttachments = Nothing
Set objMsg = Nothing
Set objOL = Nothing
End Sub
End If
objMsg.Delete
ExitSub: