Public 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 Public 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 ' 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" - Remove strFolderpath = strFolderpath ' - New ' 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 ' Get the Sent Date and Time - JHH Addition DateFormat = Format(Date, "MMddyy") TimeFormat = Format(Time, "HHmm") ' 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 & strFile ' Save the attachment as a file. objAttachments.Item(i).SaveAsFile strFile Next i End If objMsg.Save ExitSub: Set objAttachments = Nothing Set objMsg = Nothing Set objOL = Nothing End Sub