It is easy enough to include a folder based on the date e.g. as follows, and create that folder if not present. Note that your code overwrites existing files of the same name in the target folder. To address this see http://www.vbaexpress.com/forum/show...ll-attachments
Option Explicit
Dim strFolder As String
Public Sub SaveToFolderBob()
strFolder = "For T&E"
SaveAttachments
End Sub
Public Sub SaveToFolderJim()
strFolder = "For President"
SaveAttachments
End Sub
Private 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 strDate As String
On Error Resume Next
' Get the path to your My Documents folder
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
'Debug.Print strFolderpath
' The attachment folder needs to exist
' You can change this to another folder name of your choice
' Set the Attachment folder.
Set objOL = Outlook.Application
Set objMsg = objOL.ActiveExplorer.Selection.Item(1)
'format the date the message was sent on
strDate = Format(objMsg.SentOn, "mmmm yyyy")
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
'include the month and year in the path
strFolderpath = strFolderpath & "\" & strFolder & "\" & strDate & "\"
'Debug.Print strFolderpath
If lngCount > 0 Then
'Create the folders (if not present)
CreateFolders strFolderpath
' 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 Temp folder.
strFile = strFolderpath & strFile
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
Next i
End If
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Private Function CreateFolders(strPath As String)
'Graham Mayor - http://www.gmayor.com - Last updated - 31 May 2017
'Creates the full path 'strPath' if missing or incomplete
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
Dim oFSO As Object
Dim i As Integer
Set oFSO = CreateObject("Scripting.FileSystemObject")
vPath = Split(strPath, "\")
If Left(strPath, 2) = "\\" Then
strPath = "\\" & vPath(2) & "\"
For lngPath = 3 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not oFSO.FolderExists(strPath) Then MkDir strPath
Next lngPath
Else
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not oFSO.FolderExists(strPath) Then MkDir strPath
Next lngPath
End If
lbl_Exit:
Set oFSO = Nothing
Exit Function
End Function