The two requirements require different approaches. For the sent items you need to create an event in the ThisOutlookSession module e.g.
Option Explicit
Public WithEvents olItems As Outlook.items
Public Sub Application_Startup()
Dim olNS As Outlook.NameSpace
Set olNS = Application.GetNamespace("MAPI")
Set olItems = olNS.GetDefaultFolder(olFolderSentMail).items
Exit Sub
End Sub
Private Sub olItems_ItemAdd(ByVal Item As Object)
'Graham Mayor - https://www.gmayor.com - Last updated - 15 Feb 2021
Dim sPrompt As String
Dim olFolder As Outlook.Folder
If TypeName(Item) = "MailItem" Then
On Error Resume Next
sPrompt = "Do you want to file the following message?" & vbCr & Item.Subject
If MsgBox(sPrompt, vbYesNo, "File message?") = vbYes Then
SaveItem Item
End If
End If
Exit Sub
End Sub
This event is created when Outlook is started (or you can run Application_Startup directly). It calls the SaveItem macro (below) when you agree to the prompt.
The following is created in a standard module and the main code can be called from a rule that runs the script when appropriate messages are received. There's a test option so that you can try it out with messages in your inbox to adjust the prompts and the folders etc as required. This module code I have posted several times previously.
Option Explicit
Private Const strPath As String = "C:\Outlook Message Backup\" 'The root folder where the message subfolders are located
Sub TestSaveMessage()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
SaveItem olMsg
lbl_Exit:
Exit Sub
End Sub
Public Sub SaveItem(olItem As MailItem)
'Graham Mayor - https://www.gmayor.com - Last updated - 10 Jun 2020
'May be used as a script with an Outlook rule
Dim fname As String, strFolder As String
strFolder = strPath
strFolder = strFolder & InputBox("Name of client", olItem.Subject)
If olItem.SenderEmailAddress Like "*@gmayor.com" Then 'Your email address
strFolder = strFolder & "_Sent Items\"
fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
Else
strFolder = strFolder & "_Received Items\"
fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
End If
CreateFolders strFolder
fname = Replace(fname, Chr(58) & Chr(41), "")
fname = Replace(fname, Chr(58) & Chr(40), "")
fname = Replace(fname, Chr(34), "-")
fname = Replace(fname, Chr(42), "-")
fname = Replace(fname, Chr(47), "-")
fname = Replace(fname, Chr(58), "-")
fname = Replace(fname, Chr(60), "-")
fname = Replace(fname, Chr(62), "-")
fname = Replace(fname, Chr(63), "-")
fname = Replace(fname, Chr(92), "-")
fname = Replace(fname, Chr(124), "-")
On Error GoTo err_Handler
SaveUnique olItem, strFolder, fname
lbl_Exit:
Exit Sub
err_Handler:
WriteToLog strPath & "Error Log.txt", strPath & fname
Err.Clear
GoTo lbl_Exit
End Sub
Private Function CreateFolders(strPath As String)
'An Office macro by Graham Mayor - www.gmayor.com
'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
Set oFSO = CreateObject("Scripting.FileSystemObject")
VPath = Split(strPath, "\")
strPath = VPath(0) & "\"
For lngPath = 1 To UBound(VPath)
strPath = strPath & VPath(lngPath) & "\"
If Not oFSO.FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Set oFSO = Nothing
Exit Function
End Function
Private Function SaveUnique(oItem As Object, _
strPath As String, _
strFileName As String)
'Graham Mayor - http://www.gmayor.com - Last updated - 29/03/2017
'Ensures that filenames are not overwritten
Dim lngF As Long
Dim lngName As Long
Dim FSO As Object
CreateFolders strPath
Set FSO = CreateObject("Scripting.FileSystemObject")
lngF = 1
lngName = Len(strFileName)
Do While FSO.FileExists(strPath & strFileName & ".msg") = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
'oItem.SaveAs strPath & strFileName & ".txt", olTXT ' save as text
oItem.SaveAs strPath & strFileName & ".msg", olMsg 'save as msg format
lbl_Exit:
Exit Function
End Function