Comment extrayez-vous les adresses électroniques du champ 'to' dans Outlook?

On dirait, pour les adresses électroniques en dehors de votre organisation, l'adresse SMTP est cachée dans e-mailObject.Recipients (i) .Address code>, bien qu'il ne semble pas vous permettre de distinguer / Cc / bcc.

Le code Microsoft me donnait une erreur et certaines enquêtes révèlent que la page Schema n'est plus disponible. Je voulais une liste des adresses électroniques du point de vue-la-semi-colonie dans mon organisation d'échange ou en dehors de celui-ci. En combinant avec une autre réponse S / O pour convertir les noms d'affichage des courriels de l'entreprise interne aux noms SMTP, cela fait le tour. P>

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

Les réponses ci-dessus n'ont pas fonctionné pour moi. Je pense qu'ils ne fonctionnent que lorsque le destinataire est dans le carnet d'adresses. Le code suivant est également capable de rechercher des adresses électroniques de l'extérieur de l'organisation. De plus, il fait une distinction entre 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

C'est ce qui a fonctionné pour moi avec Outlook 2019. Utilisez votre nom de domaine interne. Peut-être besoin de peaufiner encore - pas fortement testé. Passez le code dans le module iOoutlookSession. (Mis à jour pour gérer les listes de distribution 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

Une autre alternative de code (basée initialement sur la réponse de @andreeSdl) qui devrait pouvoir être utilisée ...

passer dans un MailItem à la fonction e-mailddressinfo pour obtenir un tableau des champs de l'expéditeur, et CC à partir du message xxx