Sample Code

Below are samples of code I have built to support my Orion and Bird Dog projects.

Contents

VBA

• Pull Contact data from Outlook into an Excel Spreadsheet

VBA

Pull Contact data from Outlook into an Excel spreadsheet. 
There are 155 attributes for an Outlook ContactItem.  Below only include a few for illustration.  To include the rest, follow the same pattern.  Be sure you add entries to generate the headers as well.

Public Sub gatherOutlookContactItems(contactFolder As Outlook.Folder)
'Author: Matthew Looman
'Purpose: Retrieves Contact Items from the contactFolder and writes the data to a new Worksheet
'Parameters:
'  contactFolder As Outlook.Folder -- An outlook folder which contains the contact objects.
  Dim currentContact As Outlook.ContactItem   'The ContactItem which contains the current row's data
  Dim restrictedList As Outlook.Items
  Dim contactListWorksheet As Worksheet
  Dim contactListRange As Range
  Dim rowNumber As Integer
  Dim columnNumber As Integer
  Dim originalCalculation As Integer
  Dim originalCalculateBeforeSave As Integer
  
  'Store the current Calculation and CalculateBeforeSave parameters and then turn off automatic calculation
  'If automatic calculation is on, the procedure will move incredibly slow, 
  ' as each calculation has to be performed after each cell value is updated.  
  originalCalculation = Application.Calculation
  originalCalculateBeforeSave = Application.CalculateBeforeSave
  Application.Calculation = xlCalculationManual
  Application.CalculateBeforeSave = False
  
  'Verify there are records in the folder and that the default record type is ContactItem
  If contactFolder.Items.Count > 0 And contactFolder.DefaultItemType = olContactItem  Then
 
    'Create the new worksheet
    Set contactListWorksheet = Application.ThisWorkbook.Worksheets.Add
    contactListWorksheet.Name = "Contact-" & Format(Now(), "yyyymmdd hhmmss") 'Adding the timestamp is a workaround to avoid duplicate worksheet names.
    Set contactListRange = contactListWorksheet.Cells      'Get the range of cells for the new worksheet
 
    'Set the Column Headers
    rowNumber = 1
    contactListRange.Cells(rowNumber, 1) = "Source"
    contactListRange.Cells(rowNumber, 2) = "EntryID"
    contactListRange.Cells(rowNumber, 3) = "FullName"
    contactListRange.Cells(rowNumber, 4) = "FileAs"
    contactListRange.Cells(rowNumber, 5) = "FirstName"
    contactListRange.Cells(rowNumber, 6) = "MiddleName"
    contactListRange.Cells(rowNumber, 7) = "LastName"
    contactListRange.Cells(rowNumber, 8) = "Title"
    contactListRange.Cells(rowNumber, 9) = "Suffix"
    contactListRange.Cells(rowNumber, 10) = "NickName"
    contactListRange.Cells(rowNumber, 11) = "Initials"
    contactListRange.Cells(rowNumber, 12) = "CompanyName"
    contactListRange.Cells(rowNumber, 13) = "Department"
    contactListRange.Cells(rowNumber, 14) = "JobTitle"
  
    'Iterate through each contact in the folder, appending its data into the worksheet.
    'The If-Then statements prevent empty strings from being added to the cells when there isn't data
    'Boolean, date and enumerated types will not work when compared to the empty string.
    'For these the condition statement needs to be removed or modified.
    For Each currentContact In contactFolder.Items
      rowNumber = rowNumber + 1
      contactListRange.Cells(rowNumber, 1) = contactFolder.folderPath
      If currentContact.EntryID <> "" Then contactListRange.Cells(rowNumber, 2) = currentContact.EntryID
      If currentContact.FullName <> "" Then contactListRange.Cells(rowNumber, 3) = currentContact.FullName
      If currentContact.FileAs <> "" Then contactListRange.Cells(rowNumber, 4) = currentContact.FileAs
      If currentContact.FirstName <> "" Then contactListRange.Cells(rowNumber, 5) = currentContact.FirstName
      If currentContact.MiddleName <> "" Then contactListRange.Cells(rowNumber, 6) = currentContact.MiddleName
      If currentContact.LastName <> "" Then contactListRange.Cells(rowNumber, 7) = currentContact.LastName
      If currentContact.Title <> "" Then contactListRange.Cells(rowNumber, 8) = currentContact.Title
      If currentContact.Suffix <> "" Then contactListRange.Cells(rowNumber, 9) = currentContact.Suffix
      If currentContact.NickName <> "" Then contactListRange.Cells(rowNumber, 10) = currentContact.NickName
      If currentContact.Initials <> "" Then contactListRange.Cells(rowNumber, 11) = currentContact.Initials
      If currentContact.CompanyName <> "" Then contactListRange.Cells(rowNumber, 12) = currentContact.CompanyName
      If currentContact.Department <> "" Then contactListRange.Cells(rowNumber, 13) = currentContact.Department
      If currentContact.JobTitle <> "" Then contactListRange.Cells(rowNumber, 14) = currentContact.JobTitle) = currentContact.Categories
'If rowNumber = 25 Then Exit For 'Uncomment this line while testing to limit the number of records.
    Next currentItem
 
  End If

getContactList_Exit:
  'Return the calculation parameters to their original settings.
  Application.Calculation = originalCalculation
  Application.CalculateBeforeSave = originalCalculateBeforeSave
  Exit Sub
  
getContactList_Error:
'Placeholder for error handling.
 
End Sub

Sample Code by Matthew Looman is licensed under a Creative Commons Attribution 4.0 International License.

All programs contained herein are provided to you "AS IS" without any warranties of any kind. The implied warranties of non-infringement, merchantability and fitness for a particular purpose are expressly disclaimed.