自动密件抄送 - 多个电子邮件地址

Question

我想自动密件抄送两个电子邮件地址。

我从 groovypost.com 找到了这段代码，但它只能密件抄送一个地址。

Dim objRecip As Recipient
Dim strMsg As String
Dim res As Integer
Dim strBcc As String
On Error Resume Next

' #### USER OPTIONS ####
' address for Bcc -- must be SMTP address or resolvable
' to a name in the address book
strBcc = "SomeEmailAddress@domain.com"

Set objRecip = Item.Recipients.Add(strBcc)
objRecip.Type = olBCC
If Not objRecip.Resolve Then
    strMsg = "Could not resolve the Bcc recipient. " & _
      "Do you want still to send the message?"
    res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, _
      "Could Not Resolve Bcc Recipient")
    If res = vbNo Then
        Cancel = True
    End If
End If

End If

Set objRecip = Nothing

Answer 1

下面的调整应该允许您输入任意数量的地址，前提是您用分号分隔它们 ;。它创建一个地址数组，并为存在的多个电子邮件迭代重复该过程。

旁注。 我查了一下我认为是你提到的 this article。我注意到它强烈声称此代码不会将 BCC 记录存储在发件人的发件箱中。我不相信这是真的。因此，我不确定使用此 VBA 代码与仅设置消息规则相比的真正优势是什么。

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'make sure to separate with ;
Const strBcc As String = "first_email_Address@yopmail.com;second_email_Address@yopmail.com"

Dim objRecip As Recipient, strMsg As String, res As Long, i As Long
'On Error Resume Next

Dim theAddresses() As String
    theAddresses = Split(strBcc, ";", -1)

For i = LBound(theAddresses) To UBound(theAddresses)

    Set objRecip = Item.Recipients.Add(theAddresses(i))
    objRecip.Type = olBCC

    If Not objRecip.Resolve Then
        
        strMsg = "Could not resolve the Bcc recipient. " & _
            "Do you want still to send the message?"
    
        res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, _
        "Could Not Resolve Bcc Recipient")
            
        If res = vbNo Then
            Cancel = True
            End
        End If
    End If
Next i

Set objRecip = Nothing
End Sub

自动密件抄送 - 多个电子邮件地址

Auto BCC - Multiple Email Addresses

outlook

vba

bcc