如何從 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 鏈接的代碼片段，展示了如何使用 Recipients 對象獲取電子郵件地址（片段在 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 ，盡管它似乎不允許您區分 To/CC/BCC。

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 電子郵件地址。 我發現另一個 StackOverflow 答案中的這個函數很有幫助：

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

這就是 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

Answer 5

另一個代碼替代方案（最初基於@andreasDL 的回答）應該可以使用...

將MailItem傳遞給EmailAddressInfo函數以從郵件中獲取 Sender、To 和 CC 字段的數組

Private Const olOriginator As Long = 0, olTo As Long = 1, olCC As Long = 2, olBCC As Long = 3

Function PrintEmailAddresses(olItem As MailItem)
    If olItem.Class <> olMail Then Exit Function
    
    Dim Arr As Variant: Arr = EmailAddressInfo(olItem)
    Debug.Print "Sender: " & Arr(0)
    Debug.Print "To Address: " & Arr(1)
    Debug.Print "CC Address: " & Arr(2)
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