自动密件抄送发件人邮件答案

【问题标题】：Automatic bcc to sender mail自动密件抄送发件人邮件
【发布时间】：2016-01-14 06:42:23
【问题描述】：

我想在 VBA Outlook 2016 中编写代码，以便在我发送的每封邮件中发送密件抄送，我有很多发件人邮件，一个 Outlook 帐户上有很多电子邮件。

所以每次我从 x@domaine.com 发送一封电子邮件时，都会自动从 x@domaine.com 发送一封密件抄送电子邮件，如果我从 y@domaine1.com 发送同样会向 y@domaine1.com 发送一封密件抄送

我尝试了这段代码，但它不起作用，并且在我的安全宏中全部启用了

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 myOlApp As Outlook.Application
Dim myOlMsg As Outlook.MailItem

On Error Resume Next

Set myOlApp = CreateObject("Outlook.Application")
Set myMsg = myOlApp.ActiveInspector.CurrentItem

strBcc = myMsg.SenderEmailAddress

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
Set objRecip = Nothing

End Sub

【问题讨论】：

On Error Resume Next 隐藏错误。去掉就可以调试了。

标签： vba outlook outlook-2016

【解决方案1】：

对您的问题有点困惑，假设您在 Outlook 上设置了多个帐户，那么这应该会给您 CurrenUser。属性来获取当前登录用户的名称。

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim olNamespace As Outlook.NameSpace
    Dim olRec As Outlook.Recipient
    Dim Address$

    Set olNamespace = Application.GetNamespace("MAPI")

    Address = olNamespace.CurrentUser

    Set olRec = Item.Recipients.Add(Address)
    olRec.Type = olBCC
    olRec.Resolve
End Sub

【讨论】：

【解决方案2】：

试试 SendUsingAccount

见https://msdn.microsoft.com/en-us/library/office/ff869311.aspx

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim objRecip As Recipient
Dim strMsg As String
Dim res As vbMsgBoxResult
Dim strBcc As String

'Dim myOlApp As Outlook.Application
'Dim myOlMsg As Outlook.MailItem

' hides errors, this is not a good thing
'On Error Resume Next 

' You can use the already running instance of Outlook
'Set myOlApp = CreateObject("Outlook.Application")

' CurrentItem is Item: ByVal Item As Object
'Set myMsg = myOlApp.ActiveInspector.CurrentItem

'strBcc = myMsg.SenderEmailAddress
strBcc = Item.SendUsingAccount

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

Set objRecip = Nothing

End Sub

【讨论】：

【解决方案3】：

要发送的项目作为参数传递给您的代码，请勿使用myOlApp.ActiveInspector.CurrentItem。检查器可能已经关闭，或者消息可能已创建为内联响应。

【讨论】：