I have covered this several times before, however it bears repetition. You need something like the following which will save a selected message in the named folder, or you can run SaveItem as a script from a rule to process the messages as they arrive or in conjunction with a send event macro to process them as they are sent. You can save as messagfe format or text - the codes for both are shown.
Change
Const strPath As String = "C:\Path\Outlook Message Backup\" to reflect where you want to save the messages (the path will be created if it doesn't exist).
And change
If olItem.sender Like "*@gmayor.com" Then
to reflect your domain used for sending the messages
Code:
Option Explicit
Sub SaveMessage()
'An Outlook macro by Graham Mayor - www.gmayor.com
'Saves the currently selected message
Dim olMsg As MailItem
Dim sPath As String
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
SaveItem olMsg
lbl_Exit:
Set olMsg = Nothing
Exit Sub
End Sub
Private Sub SaveItem(olItem As MailItem)
'Graham Mayor - http://www.gmayor.com - Last updated - 14 Mar 2018
'The main macro called by the above macros.
'This macro can be used as a script to save the messages as they arrive
'18-03-14 - 10.11 -fr Mr A - Website Question"
Dim fname As String
Const strPath As String = "C:\Path\Outlook Message Backup\"
CreateFolders strPath
If olItem.sender Like "*@gmayor.com" Then 'Your domain
fname = Format(olItem.SentOn, "yy-mm-dd") & " - " & _
Format(olItem.SentOn, "HH.MM") & " - " & olItem.SenderName & " - " & olItem.Subject
Else
fname = Format(olItem.ReceivedTime, "yy-mm-dd") & " - " & _
Format(olItem.ReceivedTime, "HH.MM") & " - " & olItem.SenderName & " - " & olItem.Subject
End If
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, strPath, 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)
'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
Private Function SaveUnique(oItem As Object, _
strPath As String, _
strFileName As String)
'An Outlook macro by Graham Mayor - www.gmayor.com
'Ensures that filenames are not overwritten
Dim lngF As Long
Dim lngName As Long
Dim fso As Object
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
oItem.SaveAs strPath & strFileName & ".msg", olMsg
lbl_Exit:
Exit Function
End Function
Sub WriteToLog(strPath As String, strValue As String)
Dim fso As Object
Dim ff As Long
Set fso = CreateObject("Scripting.FileSystemObject")
ff = FreeFile
If fso.FileExists(strPath) Then
Open strPath For Append As #ff
Else
Open strPath For Output As #ff
End If
Print #ff, strValue
Close #ff
lbl_Exit:
Exit Sub
End Sub