Outlook VBA代码修复：避免重复添加CC邮箱及自动BCC设置

原代码重复添加CC的核心问题是：直接通过Recipient.Address判断邮箱是否存在时，若收件人来自通讯录，Address会返回Exchange格式地址（如EX:/O=XXX/OU=XXX/cn=Recipients/cn=XXX）而非SMTP地址，导致判断失效，进而重复添加。以下是修复后的完整代码：

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim objRecip As Recipient
    Dim strMsg As String
    Dim res As Integer
    Dim strBcc As String
    Dim strCc As String
    Dim currentRecip As Recipient ' 显式声明循环变量，避免隐式声明问题
    
    On Error Resume Next

    ' #### 用户配置 ####
    strBcc = "email1@exampleemail.com"
    strCc = "email2@exampleemail.com"

    ' 自动添加指定BCC（先检查是否已存在，避免重复）
    If Not IsRecipientExists(Item.Recipients, strBcc) Then
        Set objRecip = Item.Recipients.Add(strBcc)
        objRecip.Type = olBCC
        If Not objRecip.Resolve Then
            strMsg = "无法解析BCC收件人。是否继续发送邮件？"
            res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, "BCC解析失败")
            If res = vbNo Then Cancel = True
        End If
    End If

    ' 检查指定邮箱是否已在收件人/CC/BCC中，不存在则添加为CC
    If Not IsRecipientExists(Item.Recipients, strCc) Then
        Set objRecip = Item.Recipients.Add(strCc)
        objRecip.Type = olCC
        If Not objRecip.Resolve Then
            strMsg = "无法解析CC收件人。是否继续发送邮件？"
            res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, "CC解析失败")
            If res = vbNo Then Cancel = True
        End If
    End If

    Set objRecip = Nothing
    Set currentRecip = Nothing
End Sub

' 辅助函数：检查指定SMTP地址是否已存在于收件人列表中
Private Function IsRecipientExists(recipients As Recipients, targetSmtp As String) As Boolean
    Dim recip As Recipient
    Dim smtpAddr As String
    
    IsRecipientExists = False
    On Error Resume Next
    
    For Each recip In recipients
        ' 获取收件人的SMTP地址，兼容直接输入和通讯录选择的情况
        smtpAddr = GetRecipientSmtpAddress(recip)
        ' 忽略大小写对比，避免大小写差异导致判断失误
        If LCase(smtpAddr) = LCase(targetSmtp) Then
            IsRecipientExists = True
            Exit For
        End If
    Next recip
End Function

' 辅助函数：获取收件人的SMTP地址
Private Function GetRecipientSmtpAddress(recip As Recipient) As String
    Dim exchangeUser As ExchangeUser
    Dim exchangeDistributionList As ExchangeDistributionList
    
    GetRecipientSmtpAddress = recip.Address ' 默认返回原始地址
    
    ' 如果是Exchange类型的收件人，尝试获取SMTP地址
    If recip.AddressEntry.AddressEntryUserType = olExchangeUserAddressEntry Then
        Set exchangeUser = recip.AddressEntry.GetExchangeUser
        If Not exchangeUser Is Nothing Then
            GetRecipientSmtpAddress = exchangeUser.PrimarySmtpAddress
        End If
    ElseIf recip.AddressEntry.AddressEntryUserType = olExchangeDistributionListAddressEntry Then
        Set exchangeDistributionList = recip.AddressEntry.GetExchangeDistributionList
        If Not exchangeDistributionList Is Nothing Then
            GetRecipientSmtpAddress = exchangeDistributionList.PrimarySmtpAddress
        End If
    End If
End Function

关键修复点 #

• 适配多种收件人类型：通过GetRecipientSmtpAddress函数，无论收件人是直接输入的SMTP地址还是通讯录中的Exchange账户，都能准确获取到标准SMTP地址，解决判断失效问题。
• 统一存在性检查逻辑：用IsRecipientExists函数封装检查逻辑，同时覆盖BCC和CC的重复添加问题，代码更简洁可维护。
• 显式声明变量：修复原代码中循环变量未声明的隐式声明问题，避免潜在错误。
• 大小写兼容判断：邮箱地址不区分大小写，统一转换为小写后对比，避免因大小写差异导致的误判。
• 优化BCC添加逻辑：原代码会重复添加BCC，修复后先检查BCC是否已存在，再决定是否添加，逻辑更合理。

内容的提问来源于stack exchange，提问作者Rycliff