如何从Outlook会议请求中导出电子邮件地址

Question

我向所有公司（4000+）发送了一份outlook（2010）会议请求，现在我想向接受请求或暂时接受的人发送一封额外的电子邮件。

我该怎么做？当我点击联系Atendees - ＆gt;新的电子邮件发送给Atendees 在功能区中它只是向所有公司发送回复，而不仅仅是那些接受的人。我还尝试导出联系人，但它只能导出名称别名而不是整个电子邮件地址。

有什么建议吗？

由于

Answer 1

此处找到解决方案的基础Get Meeting Attendee List Macro

这是一个小小的改变。

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

在@niton编写的内容的基础上，我增加了对检查全局地址列表的支持。可以通过迭代myAddressLists来扩展此代码以搜索所有可用的地址列表，但是，在大多数情况下，这可能超出所需的范围。

请注意，这并不是针对速度进行优化的，但是即使有几百人参加GAL的列表也不会花费很长时间来遍历计算机。由于此操作不是很经常运行，因此优化它所节省的时间似乎并不值得。

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