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
|