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

Option Explicit

' VBA Script that gets list of Outlook Contacts
' 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 other scripts at http://www.GregThatcher.com for other ways to get contact properties)
Public Sub GetListOfContacts()
    On Error GoTo On_Error
    
    Dim Session As Outlook.NameSpace
    Dim Report As String
    Dim ContactFolder As Outlook.Folder
    Dim currentItem As Object
    Dim currentContact As ContactItem
    Set Session = Application.Session
    
    Set ContactFolder = Session.GetDefaultFolder(olFolderContacts)
    
    For Each currentItem In ContactFolder.Items
        If (currentItem.Class = olContact) Then
            Set currentContact = currentItem
            
            
            Report = Report & AddToReportIfNotBlank("Full Name", currentContact.FullName)
            Report = Report & AddToReportIfNotBlank("Account", currentContact.Account)
            'Report = Report & AddToReportIfNotBlank("Anniversary", currentContact.Anniversary)
            Report = Report & AddToReportIfNotBlank("AssistantName", currentContact.AssistantName)
            Report = Report & AddToReportIfNotBlank("AssistantTelephoneNumber", currentContact.AssistantTelephoneNumber)
            Report = Report & AddToReportIfNotBlank("BillingInformation", currentContact.BillingInformation)
            'Report = Report & AddToReportIfNotBlank("Birthday", currentContact.Birthday)
            Report = Report & AddToReportIfNotBlank("Body", currentContact.Body)
            Report = Report & AddToReportIfNotBlank("Business2TelephoneNumber", currentContact.Business2TelephoneNumber)
            Report = Report & AddToReportIfNotBlank("BusinessAddress", currentContact.BusinessAddress)
            Report = Report & AddToReportIfNotBlank("BusinessAddressCity", currentContact.BusinessAddressCity)
            Report = Report & AddToReportIfNotBlank("BusinessAddressCountry", currentContact.BusinessAddressCountry)
            Report = Report & AddToReportIfNotBlank("BusinessAddressPostalCode", currentContact.BusinessAddressPostalCode)
            Report = Report & AddToReportIfNotBlank("BusinessAddressPostOfficeBox", currentContact.BusinessAddressPostOfficeBox)
            Report = Report & AddToReportIfNotBlank("BusinessAddressState", currentContact.BusinessAddressState)
            Report = Report & AddToReportIfNotBlank("BusinessAddressStreet", currentContact.BusinessAddressStreet)
            'Report = Report & AddToReportIfNotBlank("BusinessCardLayoutXml", currentContact.BusinessCardLayoutXml)
            Report = Report & AddToReportIfNotBlank("BusinessCardType", currentContact.BusinessCardType)
            Report = Report & AddToReportIfNotBlank("BusinessFaxNumber", currentContact.BusinessFaxNumber)
            Report = Report & AddToReportIfNotBlank("BusinessHomePage", currentContact.BusinessHomePage)
            Report = Report & AddToReportIfNotBlank("BusinessTelephoneNumber", currentContact.BusinessTelephoneNumber)
            Report = Report & AddToReportIfNotBlank("CallbackTelephoneNumber", currentContact.CallbackTelephoneNumber)
            Report = Report & AddToReportIfNotBlank("CarTelephoneNumber", currentContact.CarTelephoneNumber)
            Report = Report & AddToReportIfNotBlank("Categories", currentContact.Categories)
            Report = Report & AddToReportIfNotBlank("Children", currentContact.Children)
            Report = Report & AddToReportIfNotBlank("Companies", currentContact.Companies)
            Report = Report & AddToReportIfNotBlank("CompanyAndFullName", currentContact.CompanyAndFullName)
            Report = Report & AddToReportIfNotBlank("CompanyLastFirstNoSpace", currentContact.CompanyLastFirstNoSpace)
            Report = Report & AddToReportIfNotBlank("CompanyLastFirstSpaceOnly", currentContact.CompanyLastFirstSpaceOnly)
            Report = Report & AddToReportIfNotBlank("CompanyMainTelephoneNumber", currentContact.CompanyMainTelephoneNumber)
            Report = Report & AddToReportIfNotBlank("CompanyName", currentContact.CompanyName)
            Report = Report & AddToReportIfNotBlank("ComputerNetworkName", currentContact.ComputerNetworkName)
            Report = Report & AddToReportIfNotBlank("ConversationIndex ", currentContact.ConversationIndex)
            Report = Report & AddToReportIfNotBlank("ConversationTopic", currentContact.ConversationTopic)
            Report = Report & AddToReportIfNotBlank("CreationTime", currentContact.CreationTime)
            Report = Report & AddToReportIfNotBlank("CustomerID", currentContact.CustomerID)
            Report = Report & AddToReportIfNotBlank("Department", currentContact.Department)
            Report = Report & AddToReportIfNotBlank("DownloadState", currentContact.DownloadState)
            Report = Report & AddToReportIfNotBlank("Email1Address", currentContact.Email1Address)
            Report = Report & AddToReportIfNotBlank("Email1AddressType", currentContact.Email1AddressType)
            Report = Report & AddToReportIfNotBlank("Email1DisplayName", currentContact.Email1DisplayName)
            'Report = Report & AddToReportIfNotBlank("Email1EntryID", currentContact.Email1EntryID)
            Report = Report & AddToReportIfNotBlank("Email2Address", currentContact.Email2Address)
            Report = Report & AddToReportIfNotBlank("Email2AddressType", currentContact.Email2AddressType)
            Report = Report & AddToReportIfNotBlank("Email2DisplayName", currentContact.Email2DisplayName)
            Report = Report & AddToReportIfNotBlank("Email2EntryID", currentContact.Email2EntryID)
            Report = Report & AddToReportIfNotBlank("Email3Address", currentContact.Email3Address)
            Report = Report & AddToReportIfNotBlank("Email3AddressType", currentContact.Email3AddressType)
            Report = Report & AddToReportIfNotBlank("Email3DisplayName ", currentContact.Email3DisplayName)
            Report = Report & AddToReportIfNotBlank("Email3EntryID ", currentContact.Email3EntryID)
            Report = Report & AddToReportIfNotBlank("EntryID", currentContact.Account)
            Report = Report & AddToReportIfNotBlank("FileAs", currentContact.FileAs)
            Report = Report & AddToReportIfNotBlank("FirstName", currentContact.FirstName)
            Report = Report & AddToReportIfNotBlank("FTPSite", currentContact.FTPSite)
            Report = Report & AddToReportIfNotBlank("FullName", currentContact.FullName)
            Report = Report & AddToReportIfNotBlank("FullNameAndCompany", currentContact.FullNameAndCompany)
            Report = Report & AddToReportIfNotBlank("Gender", currentContact.Gender)
            Report = Report & AddToReportIfNotBlank("GovernmentIDNumber", currentContact.GovernmentIDNumber)
            Report = Report & AddToReportIfNotBlank("HasPicture", currentContact.HasPicture)
            Report = Report & AddToReportIfNotBlank("Hobby", currentContact.Hobby)
            Report = Report & AddToReportIfNotBlank("Home2TelephoneNumber", currentContact.Home2TelephoneNumber)
            Report = Report & AddToReportIfNotBlank("HomeAddress ", currentContact.HomeAddress)
            Report = Report & AddToReportIfNotBlank("HomeAddressCity", currentContact.HomeAddressCity)
            Report = Report & AddToReportIfNotBlank("HomeAddressCountry", currentContact.HomeAddressCountry)
            Report = Report & AddToReportIfNotBlank("HomeAddressPostalCode ", currentContact.HomeAddressPostalCode)
            Report = Report & AddToReportIfNotBlank("HomeAddressPostOfficeBox", currentContact.HomeAddressPostOfficeBox)
            Report = Report & AddToReportIfNotBlank("HomeAddressState", currentContact.HomeAddressState)
           
            Report = Report & AddToReportIfNotBlank("HomeAddressStreet", currentContact.HomeAddressStreet)
            Report = Report & AddToReportIfNotBlank("HomeFaxNumber", currentContact.HomeFaxNumber)
            Report = Report & AddToReportIfNotBlank("HomeTelephoneNumber", currentContact.HomeTelephoneNumber)
            Report = Report & AddToReportIfNotBlank("IMAddress", currentContact.IMAddress)
            Report = Report & AddToReportIfNotBlank("Importance", currentContact.Importance)
            Report = Report & AddToReportIfNotBlank("Initials", currentContact.Initials)
            Report = Report & AddToReportIfNotBlank("InternetFreeBusyAddress", currentContact.InternetFreeBusyAddress)
            Report = Report & AddToReportIfNotBlank("IsConflict", currentContact.IsConflict)
            Report = Report & AddToReportIfNotBlank("ISDNNumber", currentContact.ISDNNumber)
            Report = Report & AddToReportIfNotBlank("IsMarkedAsTask", currentContact.IsMarkedAsTask)
            Report = Report & AddToReportIfNotBlank("JobTitle", currentContact.JobTitle)
            Report = Report & AddToReportIfNotBlank("Journal", currentContact.Journal)
            Report = Report & AddToReportIfNotBlank("Language", currentContact.Language)
            Report = Report & AddToReportIfNotBlank("LastFirstAndSuffix", currentContact.LastFirstAndSuffix)
            Report = Report & AddToReportIfNotBlank("LastFirstNoSpace", currentContact.LastFirstNoSpace)
            Report = Report & AddToReportIfNotBlank("LastFirstNoSpaceAndSuffix", currentContact.LastFirstNoSpaceAndSuffix)
            Report = Report & AddToReportIfNotBlank("LastFirstNoSpaceCompany", currentContact.LastFirstNoSpaceCompany)
            Report = Report & AddToReportIfNotBlank("LastFirstSpaceOnly", currentContact.LastFirstSpaceOnly)
            Report = Report & AddToReportIfNotBlank("LastFirstSpaceOnlyCompany", currentContact.LastFirstSpaceOnlyCompany)
            Report = Report & AddToReportIfNotBlank("LastModificationTime", currentContact.LastModificationTime)
            Report = Report & AddToReportIfNotBlank("LastName", currentContact.LastName)
            Report = Report & AddToReportIfNotBlank("LastNameAndFirstName", currentContact.LastNameAndFirstName)
            'Report = Report & AddToReportIfNotBlank("Links", currentContact.Links)
            Report = Report & AddToReportIfNotBlank("MailingAddress", currentContact.MailingAddress)
            Report = Report & AddToReportIfNotBlank("MailingAddressCity", currentContact.MailingAddressCity)
            Report = Report & AddToReportIfNotBlank("MailingAddressCountry", currentContact.MailingAddressCountry)
            Report = Report & AddToReportIfNotBlank("MailingAddressPostalCode", currentContact.MailingAddressPostalCode)

            Report = Report & AddToReportIfNotBlank("MailingAddressPostOfficeBox", currentContact.MailingAddressPostOfficeBox)
            Report = Report & AddToReportIfNotBlank("MailingAddressState", currentContact.MailingAddressState)
            Report = Report & AddToReportIfNotBlank("MailingAddressStreet", currentContact.MailingAddressStreet)
            Report = Report & AddToReportIfNotBlank("ManagerName", currentContact.ManagerName)
            Report = Report & AddToReportIfNotBlank("MarkForDownload", currentContact.MarkForDownload)
            Report = Report & AddToReportIfNotBlank("MessageClass", currentContact.MessageClass)
            Report = Report & AddToReportIfNotBlank("MiddleName", currentContact.MiddleName)
            Report = Report & AddToReportIfNotBlank("Mileage", currentContact.Mileage)
            Report = Report & AddToReportIfNotBlank("MobileTelephoneNumber", currentContact.MobileTelephoneNumber)
            Report = Report & AddToReportIfNotBlank("NetMeetingAlias", currentContact.NetMeetingAlias)
            Report = Report & AddToReportIfNotBlank("NetMeetingServer", currentContact.NetMeetingServer)
            Report = Report & AddToReportIfNotBlank("NickName", currentContact.NickName)
            Report = Report & AddToReportIfNotBlank("NoAging", currentContact.NoAging)
            Report = Report & AddToReportIfNotBlank("OfficeLocation", currentContact.OfficeLocation)
            Report = Report & AddToReportIfNotBlank("OrganizationalIDNumber", currentContact.OrganizationalIDNumber)
            Report = Report & AddToReportIfNotBlank("OtherAddress", currentContact.OtherAddress)
            Report = Report & AddToReportIfNotBlank("OtherAddressCity", currentContact.OtherAddressCity)
            Report = Report & AddToReportIfNotBlank("OtherAddressCountry", currentContact.OtherAddressCountry)
            Report = Report & AddToReportIfNotBlank("OtherAddressPostalCode", currentContact.OtherAddressPostalCode)
            Report = Report & AddToReportIfNotBlank("OtherAddressPostOfficeBox", currentContact.OtherAddressPostOfficeBox)
            Report = Report & AddToReportIfNotBlank("OtherAddressState", currentContact.OtherAddressState)
            Report = Report & AddToReportIfNotBlank("OtherAddressStreet", currentContact.OtherAddressStreet)
            Report = Report & AddToReportIfNotBlank("OtherFaxNumber", currentContact.OtherFaxNumber)
            Report = Report & AddToReportIfNotBlank("OtherTelephoneNumber", currentContact.OtherTelephoneNumber)
            Report = Report & AddToReportIfNotBlank("OutlookInternalVersion", currentContact.OutlookInternalVersion)
            Report = Report & AddToReportIfNotBlank("OutlookVersion", currentContact.OutlookVersion)
            Report = Report & AddToReportIfNotBlank("PagerNumber", currentContact.PagerNumber)
            Report = Report & AddToReportIfNotBlank("PersonalHomePage", currentContact.PersonalHomePage)
            Report = Report & AddToReportIfNotBlank("PrimaryTelephoneNumber", currentContact.PrimaryTelephoneNumber)
            Report = Report & AddToReportIfNotBlank("Profession", currentContact.Profession)
            Report = Report & AddToReportIfNotBlank("RadioTelephoneNumber", currentContact.RadioTelephoneNumber)
            Report = Report & AddToReportIfNotBlank("ReferredBy", currentContact.ReferredBy)
            Report = Report & AddToReportIfNotBlank("ReminderOverrideDefault", currentContact.ReminderOverrideDefault)
            Report = Report & AddToReportIfNotBlank("ReminderPlaySound", currentContact.ReminderPlaySound)
            Report = Report & AddToReportIfNotBlank("ReminderSet", currentContact.ReminderSet)
            Report = Report & AddToReportIfNotBlank("ReminderSoundFile", currentContact.ReminderSoundFile)
            Report = Report & AddToReportIfNotBlank("ReminderTime", currentContact.ReminderTime)
            Report = Report & AddToReportIfNotBlank("Saved", currentContact.Saved)
            Report = Report & AddToReportIfNotBlank("SelectedMailingAddress", currentContact.SelectedMailingAddress)
            Report = Report & AddToReportIfNotBlank("Sensitivity", currentContact.Sensitivity)
            Report = Report & AddToReportIfNotBlank("Size", currentContact.Size)
            Report = Report & AddToReportIfNotBlank("Spouse", currentContact.Spouse)
            Report = Report & AddToReportIfNotBlank("Subject", currentContact.Subject)
            Report = Report & AddToReportIfNotBlank("Suffix", currentContact.Suffix)
            Report = Report & AddToReportIfNotBlank("TaskCompletedDate", currentContact.TaskCompletedDate)
            Report = Report & AddToReportIfNotBlank("TaskDueDate", currentContact.TaskDueDate)
            Report = Report & AddToReportIfNotBlank("TaskStartDate", currentContact.TaskStartDate)
            Report = Report & AddToReportIfNotBlank("TaskSubject", currentContact.TaskSubject)
            Report = Report & AddToReportIfNotBlank("TelexNumber", currentContact.TelexNumber)
            Report = Report & AddToReportIfNotBlank("Title", currentContact.Title)
            Report = Report & AddToReportIfNotBlank("ToDoTaskOrdinal", currentContact.ToDoTaskOrdinal)
            Report = Report & AddToReportIfNotBlank("TTYTDDTelephoneNumber", currentContact.TTYTDDTelephoneNumber)
            Report = Report & AddToReportIfNotBlank("UnRead", currentContact.UnRead)
            Report = Report & AddToReportIfNotBlank("User1", currentContact.User1)
            Report = Report & AddToReportIfNotBlank("User2", currentContact.User2)
            Report = Report & AddToReportIfNotBlank("User3", currentContact.User3)
            Report = Report & AddToReportIfNotBlank("User4", currentContact.User4)
            Report = Report & AddToReportIfNotBlank("WebPage", currentContact.WebPage)
            Report = Report & AddToReportIfNotBlank("YomiCompanyName", currentContact.YomiCompanyName)
            Report = Report & AddToReportIfNotBlank("YomiFirstName", currentContact.YomiFirstName)
            Report = Report & AddToReportIfNotBlank("YomiLastName", currentContact.YomiLastName)
            Report = Report & vbCrLf & vbCrLf
        End If
        
    Next
    
    
    Call CreateReportAsEmail("List of Contacts", 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.