Public Sub SaveinSenderFolder() 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, strFolder As String Dim strDeletedFiles As String Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16) ' On Error Resume Next Set objOL = Application Set objSelection = objOL.ActiveExplorer.Selection ' The attachment folder needs to exist ' You can change this to another folder name of your choice ' Check each selected item for attachments. For Each objMsg In objSelection ' Set the Attachment folder. strFolder = strFolderpath & "\OLAttachments\" Set objAttachments = objMsg.Attachments strFolder = strFolder & objMsg.SenderName & "\" ' if the sender's folder doesn't exist, create it If Not FSO.FolderExists(strFolder) Then FSO.CreateFolder (strFolder) End If 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 ' Combine with the path to the folder. strFile = strFolder & strFile ' Save the attachment as a file. objAttachments.Item(i).SaveAsFile strFile Err.Clear Next End If Next ExitSub: Set objAttachments = Nothing Set objMsg = Nothing Set objSelection = Nothing Set objOL = Nothing End Sub