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