View Single Post
 
Old 03-14-2018, 04:59 AM
gmayor's Avatar
gmayor gmayor is offline Windows 10 Office 2016
Expert
 
Join Date: Aug 2014
Posts: 4,137
gmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud of
Default

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
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote