如果收件人中的团队电子邮件地址，请删除重复项

Question

我们有一个团队电子邮件地址，我们抄送大多数信件，然后我们都会得到所有电子邮件的副本。

问题是当我们回复所有内容时，并且团队成员已经在电子邮件链中，该人将收到电子邮件 2 次。

这就是我尝试过的。

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 "[e-mail]"
RemoveAddrList.Add "[e-mail]"
RemoveAddrList.Add "[e-mail]"
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 

Answer 1

一些 Debug.Print 语句被证明很有帮助。

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 "[e-mail]"
RemoveAddrList.Add "[e-mail]"
RemoveAddrList.Add "[e-mail]"
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

Answer 2

这是我用来删除重复收件人的东西。

Set olemail = olapp.CreateItemFromTemplate(OutlookTemplate)
With olemail
' other stuff 

' check duplicate recipients
' first resolve email address per global address book 
For Each Recipient In .Recipients
    Recipient.Resolve
Next
' go through each recipients and check for dup
If .Recipients.count > 1 Then
    For i = .Recipients.count To 2 Step -1
        For j = i - 1 To 1 Step -1
            If .Recipients(i) = .Recipients(j) Then
                .Recipients.Remove (i)
                i = i - 1
            End If
         Next j
      Next i
End If
end with