我想自动密件抄送两个电子邮件地址。
我从 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
答案 0 :(得分:0)
以下调整应该允许您输入任意数量的地址,前提是您用分号 ;
分隔它们。它会创建一个地址数组,并在存在尽可能多的电子邮件迭代时重复该过程。
旁注。我确实查找了我认为您提到的 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