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

问题描述

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

我从 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 = "[email protected]"

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

解决方法

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

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

Private Sub Application_ItemSend(ByVal Item As Object,Cancel As Boolean)
'make sure to separate with ;
Const strBcc As String = "[email protected];[email protected]"

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