VBA Script that gets list of Outlook Accounts

Option Explicit

' VBA Script that gets list of Outlook Accounts
' 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
' THIS SCRIPT WILL ONLY RUN ON OUTLOOK 2007 OR LATER (it won't work on Outlook 2003)
Public Sub GetListOfAccounts()
    On Error GoTo On_Error
    
    Dim Session As Outlook.NameSpace
    Dim Report As String
    Dim Accounts As Outlook.Accounts
    Dim currentAccount As Outlook.Account
    Dim currentCategory As Outlook.Category
    
    Set Session = Application.Session
    
    Set Accounts = Session.Accounts
    
    For Each currentAccount In Accounts
                        
            
            Report = Report & AddToReportIfNotBlank("Account Type", currentAccount.AccountType)
            Report = Report & AddToReportIfNotBlank("AutoDiscoverConnectionMode", currentAccount.AutoDiscoverConnectionMode)
            
            Report = Report & AddToReportIfNotBlank("Class", currentAccount.Class)
            
            Report = Report & AddToReportIfNotBlank("DisplayName", currentAccount.DisplayName)
            Report = Report & AddToReportIfNotBlank("ExchangeConnectionMode", currentAccount.ExchangeConnectionMode)
            Report = Report & AddToReportIfNotBlank("ExchangeConnectionMode", currentAccount.ExchangeMailboxServerName)
            Report = Report & AddToReportIfNotBlank("ExchangeMailboxServerVersion", currentAccount.ExchangeMailboxServerVersion)
            Report = Report & AddToReportIfNotBlank("SmtpAddress", currentAccount.SmtpAddress)
            Report = Report & AddToReportIfNotBlank("UserName", currentAccount.UserName)
            
            Report = Report & vbCrLf
            
            Report = Report & AddToReportIfNotBlank("CurrentUser.Address", currentAccount.CurrentUser.Address)
            Report = Report & AddToReportIfNotBlank("CurrentUser.AutoResponse", currentAccount.CurrentUser.AutoResponse)
            ' Report = Report & AddToReportIfNotBlank("CurrentUser.DisplayType", currentAccount.CurrentUser.DisplayType)
            Report = Report & AddToReportIfNotBlank("CurrentUser.Index", currentAccount.CurrentUser.Index)
            Report = Report & AddToReportIfNotBlank("CurrentUser.MeetingResponseStatus", currentAccount.CurrentUser.MeetingResponseStatus)
            Report = Report & AddToReportIfNotBlank("CurrentUser.Name", currentAccount.CurrentUser.Name)
            Report = Report & AddToReportIfNotBlank("CurrentUser.Resolved", currentAccount.CurrentUser.Resolved)
            Report = Report & AddToReportIfNotBlank("CurrentUser.Sendable", currentAccount.CurrentUser.Sendable)
            Report = Report & AddToReportIfNotBlank("CurrentUser.TrackingStatus", currentAccount.CurrentUser.TrackingStatus)
            Report = Report & AddToReportIfNotBlank("currentAccount.CurrentUser.TrackingStatusTime", currentAccount.CurrentUser.TrackingStatusTime)
            Report = Report & AddToReportIfNotBlank("currentAccount.CurrentUser.Type", currentAccount.CurrentUser.Type)
            
            
            Report = Report & vbCrLf & "Delivery Store Categories"
            If currentAccount.DeliveryStore.Categories.Count > 0 Then
                For Each currentCategory In currentAccount.DeliveryStore.Categories
                    Report = Report & vbTab & AddToReportIfNotBlank("currentCategory.Name", currentCategory.Name)
                    Report = Report & vbTab & AddToReportIfNotBlank("DeliveryStore.CategoryBorderColor", currentCategory.CategoryBorderColor)
                    Report = Report & vbTab & AddToReportIfNotBlank("currentCategory.CategoryGradientBottomColor", currentCategory.CategoryGradientBottomColor)
                    Report = Report & vbTab & AddToReportIfNotBlank("currentCategory.CategoryGradientTopColor", currentCategory.CategoryGradientTopColor)
                    Report = Report & vbTab & AddToReportIfNotBlank("currentCategory.CategoryID", currentCategory.CategoryID)
                    Report = Report & vbTab & AddToReportIfNotBlank("currentCategory.Color", currentCategory.Color)
                    Report = Report & vbTab & AddToReportIfNotBlank("currentCategory.ShortcutKey", currentCategory.ShortcutKey)
                    
                    Report = Report & vbCrLf
                Next
            End If
            Report = Report & vbCrLf
            
            Report = Report & AddToReportIfNotBlank("DeliveryStore.Class", currentAccount.DeliveryStore.Class)
            Report = Report & AddToReportIfNotBlank("DeliveryStore.ExchangeStoreType", currentAccount.DeliveryStore.ExchangeStoreType)
            Report = Report & AddToReportIfNotBlank("DeliveryStore.FilePath", currentAccount.DeliveryStore.FilePath)
            Report = Report & AddToReportIfNotBlank("DeliveryStore.IsCachedExchange", currentAccount.DeliveryStore.IsCachedExchange)
            Report = Report & AddToReportIfNotBlank("DeliveryStore.IsConversationEnabled", currentAccount.DeliveryStore.IsConversationEnabled)
            Report = Report & AddToReportIfNotBlank("DeliveryStore.IsDataFileStore", currentAccount.DeliveryStore.IsDataFileStore)
            Report = Report & AddToReportIfNotBlank("DeliveryStore.IsInstantSearchEnabled", currentAccount.DeliveryStore.IsInstantSearchEnabled)
            Report = Report & AddToReportIfNotBlank("DeliveryStore.IsOpen", currentAccount.DeliveryStore.IsOpen)
            Report = Report & AddToReportIfNotBlank("DeliveryStore.StoreID", currentAccount.DeliveryStore.StoreID)
            
            Report = Report & vbCrLf
            
            Report = Report & AddToReportIfNotBlank("AutoDiscoverXml", currentAccount.AutoDiscoverXml)
            Report = Report & vbCrLf & vbCrLf
        
    Next
    
    
    Call CreateReportAsEmail("List of Tasks", Report)
    
Exiting:
        Exit Sub
On_Error:
    MsgBox "error=" & Err.Number & " " & Err.Description
    Resume Exiting
    
End Sub

Private Function AddToReportIfNotBlank(FieldName As String, FieldValue As String)
    AddToReportIfNotBlank = ""
    If (FieldValue <> "") Then
        AddToReportIfNotBlank = FieldName & " : " & FieldValue & vbCrLf
    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