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