如何从 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

但是，这会将输出作为电子邮件地址的名称，而不是带有 "something@this.domain" 的实际电子邮件地址。

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

谢谢

Answer 1

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

---

2017 年 8 月 10 日更新

回顾这个答案，我意识到我做了一件坏事，只链接某个地方而不提供更多信息。

这是来自上述 MSDN 链接的代码 sn-p，展示了如何使用 Recipients 对象获取电子邮件地址（sn-p 在 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 

Answer 2

看起来，对于组织外部的电子邮件地址，SMTP 地址隐藏在emailObject.Recipients(i).Address 中，尽管它似乎不允许您区分收件人/抄送/密件抄送。

Microsoft 代码给了我一个错误，一些调查显示架构页面不再可用。我想要一个以分号分隔的电子邮件地址列表，这些地址要么位于我的 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 电子邮件地址。我发现 another StackOverflow answer 的这个功能很有帮助：

Function ResolveDisplayNameToSMTP(sFromName) As String
    ' takes a Display Name (i.e. "James Smith") and turns it into an email address (james.smith@myco.com)
    ' 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

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

Answer 4

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

将MailItem 传递给EmailAddressInfo 函数以从消息中获取Sender、To 和CC 字段的数组

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

Answer 5

这对我来说适用于 Outlook 2019。使用您的内部域名。可能还需要一些调整 - 没有经过大量测试。将代码放在 ThisOutlookSession 模块中。 （已于 2020 年 7 月 31 日更新以处理 Exchange 分发列表。）

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