Как извлечь адреса электронной почты из поля "кому" в outlook?

Я в какой-то степени использую 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:mydocumentsemailss.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, который позволит адреса электронной почты, а не имена, которые будут записаны из 'To' текстовое поле.

спасибо

6
email outlook outlook-vba text-files vba

2 ответов

Проверьте объект коллекции получателей для вашего почтового элемента, который должен позволить вам получить адрес:http://msdn.microsoft.com/en-us/library/office/ff868695.aspx

обновление 8/10/2017

оглядываясь на этот ответ, я понял, что сделал плохую вещь, только связав где-то и не предоставив немного больше информации.

вот фрагмент кода из этой ссылки MSDN выше, показывающий, как объект Recipients может быть используется для получения адреса электронной почты (фрагмент кода):

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
11

похоже, для адресов электронной почты за пределами вашей организации, SMTP-Адрес скрыт в emailObject.Recipients(i).Address, хотя это, похоже, не позволяет вам различать/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
1