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
|
|