如何从Outlook的“收件人”字段中提取电子邮件地址？

Question

我一直在使用VBA，使用以下代码：

Sub ExtractEmail()
Dim OlApp As Outlook.Application
Dim Mailobject As Object
Dim Email As String
Dim NS As NameSpace
Dim Folder As MAPIFolder
Set OlApp = CreateObject("Outlook.Application")
' Setup Namespace
Set NS = ThisOutlookSession.Session
' Display select folder dialog
Set Folder = NS.PickFolder
' Create Text File
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile("c:\mydocuments\emailss.txt", True)
' loop to read email address from mail items.
For Each Mailobject In Folder.Items
   Email = Mailobject.To
   a.WriteLine (Email)
Next
Set OlApp = Nothing
Set Mailobject = Nothing
a.Close
End Sub

然而，这个输出结果只是电子邮件地址的名称，而不是实际的电子邮件地址，带有"[e-mail]"。

是否存在邮件对象的属性，允许从'To' 文本框中写入电子邮件地址而不是名称。

谢谢

- tread

Answer 1

请查看您邮件项目的收件人集合对象，该对象应允许您获取地址：http://msdn.microsoft.com/en-us/library/office/ff868695.aspx。

---

< p>更新于2017年8月10日

回顾这个答案，我意识到我只提供了一个链接而没有提供更多信息，这是个不好的行为。

下面是来自上述MSDN链接的代码片段，展示了如何使用收件人对象获取电子邮件地址（片段是使用VBA编写的）：

Sub GetSMTPAddressForRecipients(mail As Outlook.MailItem) 
    Dim recips As Outlook.Recipients 
    Dim recip As Outlook.Recipient 
    Dim pa As Outlook.PropertyAccessor 
    Const PR_SMTP_ADDRESS As String = _ 
        "http://schemas.microsoft.com/mapi/proptag/0x39FE001E" 
    Set recips = mail.Recipients 
    For Each recip In recips 
        Set pa = recip.PropertyAccessor 
        Debug.Print recip.name &; " SMTP=" _ 
           &; pa.GetProperty(PR_SMTP_ADDRESS) 
    Next 
End Sub 

- Jake Bathman

---

非常感谢，正是我所需要的，而且时间非常及时。 - tread

这个例子似乎不再起作用了，因为代码中使用的URL已经失效，而该URL是用于识别感兴趣的MAPI属性所必需的。 - Douglas De Rizzo Meneghetti

@DouglasDeRizzoMeneghetti 这是一个不可点击的URL。 - niton

Answer 2

似乎对于组织外的电子邮件地址，SMTP地址被隐藏在emailObject.Recipients(i).Address中，虽然它似乎不允许您区分To/CC/BCC。

微软代码给我一个错误，经过一些调查发现模式页面不再可用。我想要一个带有分号的电子邮件地址列表，这些地址要么在我的Exchange组织内，要么在组织外。将其与另一个S/O答案结合起来，以将公司内部电子邮件显示名称转换为SMTP名称，这样就可以解决问题了。

Function getRecepientEmailAddress(eml As Variant)
    Set out = CreateObject("System.Collections.Arraylist") ' a JavaScript-y array

    For Each emlAddr In eml.Recipients
        If Left(emlAddr.Address, 1) = "/" Then
            ' it's an Exchange email address... resolve it to an SMTP email address
            out.Add ResolveDisplayNameToSMTP(emlAddr)
        Else
            out.Add emlAddr.Address
        End If
    Next
    getRecepientEmailAddres = Join(out.ToArray(), ";")
End Function

如果电子邮件在您的组织内部，您需要将其转换为SMTP电子邮件地址。我从另一个StackOverflow答案中找到了这个函数，它很有帮助：

Function ResolveDisplayNameToSMTP(sFromName) As String
    ' takes a Display Name (i.e. "James Smith") and turns it into an email address ([e-mail])
    ' necessary because the Outlook address is a long, convoluted string when the email is going to someone in the organization. 
    ' source:  https://stackoverflow.com/questions/31161726/creating-a-check-names-button-in-excel

    Dim OLApp As Object 'Outlook.Application
    Dim oRecip As Object 'Outlook.Recipient
    Dim oEU As Object 'Outlook.ExchangeUser
    Dim oEDL As Object 'Outlook.ExchangeDistributionList

    Set OLApp = CreateObject("Outlook.Application")
    Set oRecip = OLApp.Session.CreateRecipient(sFromName)
    oRecip.Resolve
    If oRecip.Resolved Then
        Select Case oRecip.AddressEntry.AddressEntryUserType
            Case 0, 5 'olExchangeUserAddressEntry & olExchangeRemoteUserAddressEntry
                Set oEU = oRecip.AddressEntry.GetExchangeUser
                If Not (oEU Is Nothing) Then
                    ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
                End If
            Case 10, 30 'olOutlookContactAddressEntry & 'olSmtpAddressEntry
                    ResolveDisplayNameToSMTP = oRecip.AddressEntry.Address
        End Select
    End If
End Function

- Steven

---

谢谢，这是一个重要的更新！ - Shai Rado

Answer 3

上面的答案对我没有用。我认为它们只在收件人在通讯录中时才有效。下面的代码还可以查找组织外部的电子邮件地址。此外，它还区分了to/cc/bcc。

    Dim olRecipient As Outlook.Recipient
    Dim strToEmails, strCcEmails, strBCcEmails As String

    For Each olRecipient In item.Recipients
           
        Dim mail As String
        If olRecipient.AddressEntry Is Nothing Then
            mail = olRecipient.Address
        ElseIf olRecipient.AddressEntry.GetExchangeUser Is Nothing Then
            mail = olRecipient.Address
        Else
            mail = olRecipient.AddressEntry.GetExchangeUser.PrimarySmtpAddress
        End If
        
        Debug.Print "resolved", olRecipient.Name, mail
        
        If olRecipient.Type = Outlook.OlMailRecipientType.olTo Then
            strToEmails = strToEmails + mail & ";"
        ElseIf olRecipient.Type = Outlook.OlMailRecipientType.olCC Then
            strCcEmails = strCcEmails + mail & ";"
        ElseIf olRecipient.Type = Outlook.OlMailRecipientType.olBCC Then
            strBCcEmails = strBCcEmails + mail & ";"
        End If
        
    Next
    Debug.Print strToEmails
    Debug.Print strCcEmails
    Debug.Print strBCcEmails

- andreasDL

Answer 4

另一种代码替代方案（最初基于@andreasDL的答案）应该能够使用...

将一个MailItem传递给EmailAddressInfo函数，以获取来自邮件的发送者、收件人和抄送字段的数组

Private Const olOriginator As Long = 0, olTo As Long = 1, olCC As Long = 2, olBCC As Long = 3
'BCC addresses are not included within received messages

Function PrintEmailAddresses(olItem As MailItem)
    If olItem.Class <> olMail Then Exit Function
    
    Dim Arr As Variant: Arr = EmailAddressInfo(olItem)
    Debug.Print "Sender: " & Arr(olOriginator)
    Debug.Print "To Address: " & Arr(olTo)
    Debug.Print "CC Address: " & Arr(olCC)
End Function

Private Function EmailAddressInfo(olItem As MailItem) As Variant
    If olItem.Class <> olMail Then Exit Function
    
On Error GoTo ExitFunction
    
    Dim olRecipient As Outlook.Recipient
    Dim olEU As Outlook.ExchangeUser
    Dim olEDL As Outlook.ExchangeDistributionList
    Dim ToAddress, CCAddress, Originator, email As String
            
    With olItem
        Select Case UCase(.SenderEmailType)
            Case "SMTP": Originator = .SenderEmailAddress
            Case Else
                Set olEU = .Sender.GetExchangeUser
                If Not olEU Is Nothing Then Originator = olEU.PrimarySmtpAddress
        End Select
    End With
    
    For Each olRecipient In olItem.Recipients
       With olRecipient
            Select Case .AddressEntry.AddressEntryUserType
                Case olSmtpAddressEntry 'OlAddressEntryUserType.
                    email = .Address
                Case olExchangeDistributionListAddressEntry, olOutlookDistributionListAddressEntry
                    Set olEDL = .AddressEntry.GetExchangeDistributionList
                    email = IIf(Not olEDL Is Nothing, olEDL.PrimarySmtpAddress, "")
                Case Else
                    Set olEU = .AddressEntry.GetExchangeUser
                    email = IIf(Not olEU Is Nothing, olEU.PrimarySmtpAddress, "")
            End Select
            If email <> "" Then
                Select Case .Type
                    Case olTo: ToAddress = ToAddress & email & ";"
                    Case olCC: CCAddress = CCAddress & email & ";"
                End Select
            End If
        End With
    Next
    EmailAddressInfo = Array(Originator, ToAddress, CCAddress)
ExitFunction:
End Function

- Tragamor

---

太好了！我不知道为什么你没有包括BCC Case，希望你不介意我加上它。 - FreeSoftwareServers

BCC 是盲送的。地址没有被保存，所以添加它作为一个案例是没有意义的。我最初确实添加了它，但当我意识到它没有任何价值时就将其删除了。 - Tragamor

由于这是一个“函数”，它的用途是未知和无限的。虽然我们可能不会使用BCC功能，但例如，我仍然可以在我的“已发送”电子邮件文件夹中看到它，因此如果我需要对这些电子邮件进行某些操作，我将拥有BCC选项。我认为从函数中删除它没有任何好处。如果您不想添加它回来，我将撰写自己的答案。@Tragamor - FreeSoftwareServers

Answer 5

以下是我在Outlook 2019上使用的方法。使用您的内部域名。可能需要一些微调 - 还未经过大量测试。将代码放置在ThisOutlookSession模块中。（已更新以处理Exchange分发列表7/31/20。）

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim xMailItem As Outlook.MailItem
Dim xRecipients As Outlook.Recipients
Dim OutRec As Outlook.Recipient
Dim OutTI As Outlook.TaskItem
Dim i As Long
Dim j As Long
Dim xOKCancel As Integer
Dim sMsg As String
Dim oMembers As AddressEntries
Dim oMember As AddressEntry
Dim sDomains As String
Dim sTemp As String

On Error Resume Next
If Item.Class <> olMail Then GoTo ExitCode
sDomains = "@test1.com @test2.com"
Set xMailItem = Item
Set xRecipients = xMailItem.Recipients

'Loop through email recipients to get email addresses
For i = xRecipients.Count To 1 Step -1
    'If we have a text address entry in the email
    If InStr(xRecipients.Item(i).AddressEntry, "@") > 0 Then
        sTemp = xRecipients.Item(i).AddressEntry
        If InStrRev(sDomains, LCase(Mid(sTemp, InStr(sTemp, "@"), 254))) <= 0 Then
            sMsg = sMsg & sTemp & vbCrLf
        End If
    Else
        Select Case xRecipients.Item(i).AddressEntry.DisplayType
            Case Is = olDistList
                Set oMembers = xRecipients.Item(i).AddressEntry.Members
                For j = oMembers.Count To 1 Step -1
                    Set oMember = oMembers.Item(j)
                    sTemp = oMember.GetExchangeUser.PrimarySmtpAddress
                    If InStrRev(sDomains, LCase(Mid(sTemp, InStr(sTemp, "@"), 254))) <= 0 Then
                        sMsg = sMsg & sTemp & vbCrLf
                    End If
                    Set oMember = Nothing
                Next j
                Set oMembers = Nothing
            Case Is = olUser
                Set OutTI = Application.CreateItem(3)
                OutTI.Assign
                Set OutRec = OutTI.Recipients.Add(xRecipients.Item(i).AddressEntry)
                OutRec.Resolve
                If OutRec.Resolved Then
                    sTemp = OutRec.AddressEntry.GetExchangeUser.PrimarySmtpAddress
                    If InStrRev(sDomains, LCase(Mid(sTemp, InStr(sTemp, "@"), 254))) <= 0 Then
                         sMsg = sMsg & sTemp & vbCrLf
                    End If
                End If
                Set OutTI = Nothing
                Set OutRec = Nothing
            Case Else
                MsgBox "Unaccomodated AddressEntry.DisplayType."
                GoTo ExitCode
        End Select
    End If
Next i

'Display user message
If Len(sMsg) > 0 Then
    sMsg = "This email is addressed to the following external Recipients:" & vbCrLf & vbCrLf & sMsg
    xOKCancel = MsgBox(sMsg, vbOKCancel + vbQuestion, "Warning")
    If xOKCancel = vbCancel Then Cancel = True
End If

End Sub

- phillfri