How to export email addresses from outlook meeting request

Question

I sent an outlook (2010) meeting request to all company (4000+) and now I would like to send an additional email to those who accepted the request or accepted tentatively.

How do I do that? When I hit Contact Atendees --> New Email to Atendees in the ribbon it just send a response to all company and not only those who accepted. I also tried to export the contacts but it can only export the name alias and not the entire email addresses.

Any suggestions?

Thanks

Answer 1

The basis of the solution is found here Get Meeting Attendee List Macro

Here it is with minor changes.

Option Explicit

Sub GetAttendeeList()

Dim objApp As Outlook.Application
Dim objItem As Object
Dim objAttendees As Outlook.Recipients
Dim objAttendeeReq As String
Dim objAttendeeOpt As String
Dim objOrganizer As String
Dim dtStart As Date
Dim dtEnd As Date
Dim strSubject As String
Dim strLocation As String
Dim strNotes As String
Dim strMeetStatus As String
Dim strCopyData As String
Dim strCount  As String

Dim ino, it, ia, ide

Dim x As Long
Dim ListAttendees As mailitem

'On Error Resume Next

Set objApp = CreateObject("Outlook.Application")
Set objItem = GetCurrentItem()
Set objAttendees = objItem.Recipients

On Error GoTo EndClean:

' Is it an appointment
If objItem.Class <> 26 Then
  MsgBox "This code only works with meetings."
  GoTo EndClean:
End If

' Get the data
dtStart = objItem.Start
dtEnd = objItem.End
strSubject = objItem.Subject
strLocation = objItem.location
strNotes = objItem.body
objOrganizer = objItem.Organizer
objAttendeeReq = ""
objAttendeeOpt = ""

Set ListAttendees = Application.CreateItem(olMailItem)  ' <---

' Get The Attendee List
For x = 1 To objAttendees.count
   strMeetStatus = ""
   Select Case objAttendees(x).MeetingResponseStatus
     Case 0
       strMeetStatus = "No Response (or Organizer)"
       ino = ino + 1
     Case 1
       strMeetStatus = "Organizer"
       ino = ino + 1
     Case 2
       strMeetStatus = "Tentative"
       it = it + 1

       ListAttendees.Recipients.Add objAttendees(x) ' <---

     Case 3
       strMeetStatus = "Accepted"
       ia = ia + 1

       ListAttendees.Recipients.Add objAttendees(x) ' <---

     Case 4
       strMeetStatus = "Declined"
       ide = ide + 1

   End Select

   If objAttendees(x).Type = olRequired Then
      objAttendeeReq = objAttendeeReq & objAttendees(x).Name & vbTab & strMeetStatus & vbCrLf
   Else
      objAttendeeOpt = objAttendeeOpt & objAttendees(x).Name & vbTab & strMeetStatus & vbCrLf
   End If
Next

 strCopyData = "Organizer: " & objOrganizer & vbCrLf & "Subject:  " & strSubject & vbCrLf & _
  "Location: " & strLocation & vbCrLf & "Start:    " & dtStart & vbCrLf & "End:     " & dtEnd & _
  vbCrLf & vbCrLf & "Required: " & vbCrLf & objAttendeeReq & vbCrLf & "Optional: " & _
  vbCrLf & objAttendeeOpt & vbCrLf & "NOTES " & vbCrLf & strNotes

 strCount = "Accepted: " & ia & vbCrLf & _
  "Declined: " & ide & vbCrLf & _
  "Tentative: " & it & vbCrLf & _
  "No response: " & ino

'Set ListAttendees = Application.CreateItem(olMailItem)
  ListAttendees.body = strCopyData & vbCrLf & strCount
  ListAttendees.Display

  ListAttendees.Recipients.ResolveAll   ' <---

EndClean:
Set objApp = Nothing
Set objItem = Nothing
Set objAttendees = Nothing
End Sub

Answer 2

Building upon what @niton wrote, I've added support for checking against the Global Address List. This code could be extended to search all address lists available to you by iterating through myAddressLists , however, in most cases, that will probably be more than wanted.

Note that this isn't optimized for speed, but even a list with a few hundred people invited against a GAL of tens of thousands won't take a computer very long to iterate through. Since this doesn't get run very often, the time saved for optimizing this just didn't seem worth it.

Option Explicit

Sub GetAttendeeList()
    Dim x As Integer
    Dim y As Integer
    Dim ino As Integer
    Dim it As Integer
    Dim ia As Integer
    Dim ide As Integer
    
    Dim objApp As Outlook.Application
    Dim objItem As Object
    Dim objAttendees As Outlook.Recipients
    Dim objAttendeeReq As String
    Dim objAttendeeOpt As String
    Dim strAttendeeName As String
    Dim strAttendeeEmail As String
    Dim objOrganizer As String
    Dim dtStart As Date
    Dim dtEnd As Date
    Dim strSubject As String
    Dim strLocation As String
    Dim strNotes As String
    Dim strMeetStatus As String
    Dim strCopyData As String
    Dim strCount  As String
    Dim strCity As String
    Dim folContacts As Outlook.MAPIFolder
    Dim oContact As Outlook.ContactItem
    Dim colItems As Outlook.Items
    Dim oNS As Outlook.NameSpace
    Dim ListAttendees As MailItem
    Dim strNewRecord As String
    
    Dim myAddressLists As AddressLists
    Dim myAddressEntries As AddressEntries
    Dim myAddressEntry As AddressEntry
    Dim myExchangeUser As ExchangeUser
    Dim myExchangeDL As ExchangeDistributionList
    Dim myContactItem As ContactItem
        
    On Error Resume Next
    
    Set objApp = CreateObject("Outlook.Application")
    
    Set oNS = Application.GetNamespace("MAPI")
    Set folContacts = oNS.GetDefaultFolder(olFolderContacts)
    Set colItems = folContacts.Items
    Set myAddressLists = oNS.AddressLists
    Set myAddressEntries = myAddressLists.Item("Global Address List").AddressEntries

    Set objItem = GetCurrentItem()
    Set objAttendees = objItem.Recipients
    On Error GoTo EndClean:
    
' Is it an appointment
    If objItem.Class <> 26 Then
        MsgBox "This code only works with meetings."
        GoTo EndClean:
    End If
    
' Get the data
    dtStart = objItem.Start
    dtEnd = objItem.End
    strSubject = objItem.Subject
    strLocation = objItem.Location
    strNotes = objItem.Body
    objOrganizer = objItem.Organizer
    objAttendeeReq = ""
    objAttendeeOpt = ""
    
' Get The Attendee List
    For x = 1 To objAttendees.Count
        strMeetStatus = ""
        Select Case objAttendees(x).MeetingResponseStatus
        Case 0
            strMeetStatus = "No Response (or Organizer)"
            ino = ino + 1
        Case 1
            strMeetStatus = "Organizer"
            ino = ino + 1
        Case 2
            strMeetStatus = "Tentative"
            it = it + 1
        Case 3
            strMeetStatus = "Accepted"
            ia = ia + 1
        Case 4
            strMeetStatus = "Declined"
            ide = ide + 1
        End Select
        
        strAttendeeName = objAttendees(x).Name
        strAttendeeEmail = objAttendees(x).Address
        
        Set oContact = colItems.Find("[Email1Address] = '" & strAttendeeEmail & "'")
        
        If Not oContact Is Nothing Then
            Debug.Print "Test", oContact.BusinessAddressCity
            strCity = oContact.MailingAddressCity & ", " & oContact.MailingAddressState
        End If
        
        If InStr(strAttendeeEmail, "@") = 0 Then
            Debug.Print "Searching: " & objAttendees(x).Name
            Set myAddressEntry = myAddressEntries.GetFirst()
            
            Do While Not myAddressEntry Is Nothing
                If myAddressEntry.Address Like objAttendees(x).Address Then
                    Debug.Print "Found: " & myAddressEntry.Name
                    Set myExchangeUser = myAddressEntry.GetExchangeUser()
                    Set myExchangeDL = myAddressEntry.GetExchangeDistributionList()
                    Set myContactItem = myAddressEntry.GetContact()
                    If Not myExchangeUser Is Nothing Then
                        strAttendeeEmail = myExchangeUser.PrimarySmtpAddress
                    End If
                    If Not myExchangeDL Is Nothing Then
                        strAttendeeEmail = myExchangeDL.PrimarySmtpAddress
                    End If
                    If Not myContactItem Is Nothing Then
                        strAttendeeEmail = myContactItem.Email1Address
                    End If
                    
                    GoTo ContactFound
                End If
            
                Set myAddressEntry = myAddressEntries.GetNext()
            Loop
        End If
        
ContactFound:

        strNewRecord = objAttendees(x).Name & vbTab & strAttendeeEmail & vbTab & strMeetStatus & vbTab & strCity & vbCrLf
        
        If objAttendees(x).Type = olRequired Then
            objAttendeeReq = objAttendeeReq & strNewRecord
        Else
            objAttendeeOpt = objAttendeeOpt & strNewRecord
        End If
        
    Next
    
    strCopyData = "Organizer: " & objOrganizer & vbCrLf & "Subject:  " & strSubject & vbCrLf & _
    "Location: " & strLocation & vbCrLf & "Start:    " & dtStart & vbCrLf & "End:     " & dtEnd & _
    vbCrLf & vbCrLf & "Required: " & vbCrLf & objAttendeeReq & vbCrLf & "Optional: " & _
    vbCrLf & objAttendeeOpt & vbCrLf & "NOTES " & vbCrLf & strNotes
    
    strCount = "Accepted: " & ia & vbCrLf & _
    "Declined: " & ide & vbCrLf & _
    "Tentative: " & it & vbCrLf & _
    "No response: " & ino
    
    Set ListAttendees = Application.CreateItem(olMailItem)
    ListAttendees.Body = strCopyData & vbCrLf & strCount & vbCrLf & Time
    ListAttendees.Display
    
EndClean:
    Set objApp = Nothing
    Set objItem = Nothing
    Set objAttendees = Nothing
End Sub

Function GetCurrentItem() As Object
    Dim objApp As Outlook.Application
    
    Set objApp = Application
    On Error Resume Next
    Select Case TypeName(objApp.ActiveWindow)
    Case "Explorer"
        Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
    Case "Inspector"
        Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
    End Select
    
    Set objApp = Nothing
End Function