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

是否有一个mailobject的attributte将允许从'To'文本框中写入电子邮件地址而不是名称.

谢谢

Answer 1

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

更新8/10/2017

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

以下是上述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:  /sf/ask/2181320851/

    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