Outlook 2017 Macro pour supprimer les destinataires si l'e-mail de l'équipe dans les destinataires

Question

Nous avons une adresse e-mail de l'équipe que nous CC pour la plupart des correspondances, puis nous recevons tous une copie de tous les e-mails.

Maintenant, le problème est que lorsque nous appuyons sur répondre à tous, et qu'un membre de l'équipe a déjà été dans la chaîne de messagerie, alors cette personne recevra l'email 2 fois.

Je n'utilise pas ou ne connais pas VBA donc j'ai essayé en aveugle.

C'est ce que je fatigué mais ça ne marche pas.

`Private Sub RemoveRecipientsWhenItemSend(Item As Outlook.MailItem) 
Dim RemoveAddrList As VBA.Collection 
Dim InfoAddrList As VBA.Collection 
Dim Recipients As Outlook.Recipients 
Dim aRecipient As Outlook.Recipient 
Dim bRecipient As Outlook.Recipient 
Dim i 
Dim j 
Dim a 
Dim b 
Dim info As Boolean 
info = False 
Set RemoveAddrList = New VBA.Collection 
Set InfoAddrList = New VBA.Collection 
InfoAddrList.Add "team@company.com" 
RemoveAddrList.Add "member1@company.com" 
RemoveAddrList.Add "member2@company.com" 
Set Recipients = Item.Recipients 
For i = Recipients.Count To 1 Step -1 
Set aRecipient = Recipients.Item(i) 
For j = 1 To InfoAddrList.Count 
If LCase$(aRecipient.Address) = LCase$(InfoAddrList(j)) Then 
For a = Recipients.Count To 1 Step -1 
Set bRecipient = Recipients.Item(a) 
For b = 1 To RemoveAddrList.Count 
If LCase$(aRecipient.Address) = LCase$(RemoveAddrList(b)) Then 
Recipients.Remove i 
Exit For 
End If 
Next 
Next 
Exit For 
End If 
Next 
Next 




End Sub 
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) 
On Error Resume Next 
RemoveRecipientsWhenItemSend Item 
End Sub 
` 

Comme je l'ai dit, je ne sais pas VBA, je suis sûr que le code est mauvais, mais c'était ce que je pouvais trouver, toute aide serait grandement appréciée.

Answer 1

Quelques instructions Debug.Print se sont avérées utiles.

Option Explicit 

Private Sub RemoveRecipientsWhenItemSend(Item As Outlook.mailitem) 

Dim RemoveAddrList As VBA.Collection 
Dim InfoAddrList As VBA.Collection 

Dim Recipients As Outlook.Recipients 
Dim aRecipient As Outlook.Recipient 
Dim bRecipient As Outlook.Recipient 

Dim i 
Dim j 
Dim a 
Dim b 

Dim info As Boolean 

info = False 
Set RemoveAddrList = New VBA.Collection 
Set InfoAddrList = New VBA.Collection 

InfoAddrList.Add "team@company.com" 

RemoveAddrList.Add "member1@company.com" 
RemoveAddrList.Add "member2@company.com" 

Set Recipients = Item.Recipients 

For i = Recipients.count To 1 Step -1 

    Set aRecipient = Recipients.Item(i) 

    For j = 1 To InfoAddrList.count 

     Debug.Print LCase$(aRecipient.Address) 
     Debug.Print LCase$(InfoAddrList(j)) 

     If LCase$(aRecipient.Address) = LCase$(InfoAddrList(j)) Then 

      For a = Recipients.count To 1 Step -1 

       'Set bRecipient = Recipients.Item(a) 
       Set aRecipient = Recipients.Item(a) 

       For b = 1 To RemoveAddrList.count 

        Debug.Print vbCr & " a: " & a 
        Debug.Print " LCase$(aRecipient.Address): " & LCase$(aRecipient.Address) 
        Debug.Print " LCase$(RemoveAddrList(b)): " & LCase$(RemoveAddrList(b)) 

        If LCase$(aRecipient.Address) = LCase$(RemoveAddrList(b)) Then 
         'Recipients.Remove i 
         Recipients.Remove a 
         Exit For 
        End If 

       Next 

      Next 

      Exit For 

     End If 
    Next 
Next 

End Sub 


Private Sub RemoveRecipientsWhenItemSend_test() 
    RemoveRecipientsWhenItemSend ActiveInspector.currentItem 
End Sub