VBA Script that gets list of Outlook Rules using the Outlook Object Model

Option Explicit

' VBA Script that gets list of Outlook Rulesand Rule Properties using the Outlook Object Model
' Use Tools->Macro->Security to allow Macros to run, then restart Outlook
' Run Outlook, Press Alt+F11 to open VBA
' Programming by Greg Thatcher, http://www.GregThatcher.com
' See http://www.GregThatcher.com for other ways to get the properties of Rules
' This script uses the new Rules collection, available in Outlook 2007 and later

Public Sub GetListOfRulesUsingOutlookObjectModel()
    On Error GoTo On_Error
    
    Dim Session As Outlook.NameSpace
    Dim Report As String
    Dim currentItem As Object
    Dim currentRule As Outlook.Rule
    Dim rules As Outlook.rules
    Set Session = Application.Session
    
    Set rules = Session.DefaultStore.GetRules()
    
    For Each currentRule In rules
            
        ' Call AddToReportIfNotBlank(Report, "Actions", currentRule.Actions)
        Call AddToReportIfNotBlank(Report, "Class", currentRule.Class)
        ' Call AddToReportIfNotBlank(Report, "Conditions", currentRule.Conditions)
        Call AddToReportIfNotBlank(Report, "Enabled", currentRule.Enabled)
        ' Call AddToReportIfNotBlank(Report, "Exceptions", currentRule.Exceptions)
        Call AddToReportIfNotBlank(Report, "ExecutionOrder", currentRule.ExecutionOrder)
        Call AddToReportIfNotBlank(Report, "IsLocalRule", currentRule.IsLocalRule)
        Call AddToReportIfNotBlank(Report, "Name", currentRule.Name)
        Call AddToReportIfNotBlank(Report, "RuleType", currentRule.RuleType)
            
        Report = Report & vbCrLf & vbCrLf
        
    Next
    
    
    Call CreateReportAsEmail("List of Rules", Report)
    
Exiting:
        Exit Sub
On_Error:
    MsgBox "error=" & Err.Number & " " & Err.Description
    Resume Exiting
    
End Sub

Private Function AddToReportIfNotBlank(Report As String, FieldName As String, FieldValue)
    AddToReportIfNotBlank = ""
    If (IsNull(FieldValue) Or FieldValue <> "") Then
        AddToReportIfNotBlank = FieldName & " : " & FieldValue & vbCrLf
        Report = Report & AddToReportIfNotBlank
    End If
    
End Function

' VBA SubRoutine which displays a report inside an email
' Programming by Greg Thatcher, http://www.GregThatcher.com
Public Sub CreateReportAsEmail(Title As String, Report As String)
    On Error GoTo On_Error
    
    Dim Session As Outlook.NameSpace
    Dim mail As MailItem
    Dim MyAddress As AddressEntry
    Dim Inbox As Outlook.Folder
    
    Set Session = Application.Session
    Set Inbox = Session.GetDefaultFolder(olFolderInbox)
    Set mail = Inbox.Items.Add("IPM.Mail")
    
    Set MyAddress = Session.CurrentUser.AddressEntry
    mail.Recipients.Add (MyAddress.Address)
    mail.Recipients.ResolveAll
    
    mail.Subject = Title
    mail.Body = Report
    
    mail.Save
    mail.Display
    
    
Exiting:
        Set Session = Nothing
        Exit Sub
On_Error:
    MsgBox "error=" & Err.Number & " " & Err.Description
    Resume Exiting

End Sub