Macro rule script

[realitydrm]

Hello all. I have an outlook rule set-up to move certain incoming messages to a specified folder. I need a some kind of run script code that will:

- Move the emails that enter this outlook folder to a folder on my hard and change the file to txt
- I still would like to keep a copy in my outlook folder

[gmayor]

What format are the messages that you want to save? Plain Text e-mails will save reasonably well as text, but the results from html e-mails can be decidedly odd, and probably unusable. It is better to save as msg format which will match the original, but it will need Outlook available to view the message later. The following (which I have posted before) includes code for both. Test it with the test macro before adding the main to a rule which identifies and moves the messages to a folder. The files are saved in the folder named at the top of the macro which is created by the code if not present.

Option ExplicitPrivate Const strPath As String = "C:\Outlook Message Backup\"


Sub TestMacro()
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 - http://www.gmayor.com - Last updated - 29/03/2017
'May be used as a script with an Outlook rule
Dim fname As String
If olItem.sender Like "*@gmayor.com" Then    'Your domain
        fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
                Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
    Else
        fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
                Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & 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)
'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

[realitydrm]

Hi GM-

I'm having challenges with where to place information in the code. For example, my hard drive file name, my email, senders email, etc.

[gmayor]

The harddrive path is the value of strPath, set at the top of the macro at

Option Explicit
Private Const strPath As String = "C:\Outlook Message Backup\"

The filename is created according to the message and is the content of the variable fname.
The messages that the process refers to are set in the rule.

[realitydrm]

Hi GM-

When I try to run the test marco i get a "WriteToLog" error.

The harddrive path is the value of strPath, set at the top of the macro at

Option Explicit
Private Const strPath As String = "C:\Outlook Message Backup\"

The filename is created according to the message and is the content of the variable fname.
The messages that the process refers to are set in the rule.

[gmayor]

Oops! Sorry about that. I forgot to include the WriteToLog code. It goes in the same module after the above code

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:
    Set fso = Nothing
    Exit Sub
End Sub