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

Problems, Comments, Suggestions? Click here to contact Greg Thatcher
Please read my Disclaimer





Copyright (c) 2013 Thatcher Development Software, LLC. All rights reserved. No claim to original U.S. Gov't works.