使用VBA创建一个规则，根据使用的帐户在传出的Outlook电子邮件中添加密件抄送地址

Stackoverflow上有一个原始脚本，处理在Outlook中使用VBA脚本有条件地阻止Outlook根据发件人和收件人地址发送电子邮件的问题

我发现还有另一个VBA脚本，当用户单击Outlook中的“发送”按钮时，该脚本会自动将密件抄送地址添加到所有发出的电子邮件中，而无需用户干预

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
    On Error Resume Next

    strBcc = "HR@company.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

    Set objRecip = Nothing

End Sub

我想做的是修改此脚本，以便根据用户发送电子邮件时使用的电子邮件帐户更改要添加的密件抄送地址

例如：

我尝试了广泛的搜索，但似乎找不到一个好的例子，我可以调整

还有另一个代码示例，我就是无法正确阅读-可能是因为所有嵌入的IF语句

有人能帮我解决问题或给我指出正确的方向吗

---

安德鲁我自己找到了答案。我的代码如下：

Option Explicit

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

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

  'Figure out which email account you are using to send email
  strSendUsingAccount = Item.SendUsingAccount

  'Throw an error if you are using your internal email account
  If strSendUsingAccount = "UserName@Internal.Dom" Then
      strMsg = "You are trying to send an email using your internal Scanner Email account, which you can't do..." & vbCr & vbCr & "Please select a DIFFERENT email account to send the email from."
      res = MsgBox(strMsg, vbOKOnly + vbExclamation, "Sending Mail Error")
      Cancel = True
      Exit Sub
  End If

  'If sending using your first account
  If strSendUsingAccount = "user@privateemail.com" Then
      strBcc = ""
  End If

  'If sending using your second account
  If strSendUsingAccount = "user@workemail.com" Then
      strBcc = "HR@workemail.com"
  End If

  'Choose whether CC/BCC recipient
  Set objRecip = Item.Recipients.Add(strBcc)
  objRecip.Type = olBCC

  'Resolve it?
  objRecip.Resolve

  'Clear the recipient
  Set objRecip = Nothing

End Sub

Option Explicit

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

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

  'Figure out which email account you are using to send email
  strSendUsingAccount = Item.SendUsingAccount

  'Throw an error if you are using your internal email account
  If strSendUsingAccount = "UserName@Internal.Dom" Then
      strMsg = "You are trying to send an email using your internal Scanner Email account, which you can't do..." & vbCr & vbCr & "Please select a DIFFERENT email account to send the email from."
      res = MsgBox(strMsg, vbOKOnly + vbExclamation, "Sending Mail Error")
      Cancel = True
      Exit Sub
  End If

  'If sending using your first account
  If strSendUsingAccount = "user@privateemail.com" Then
      strBcc = ""
  End If

  'If sending using your second account
  If strSendUsingAccount = "user@workemail.com" Then
      strBcc = "HR@workemail.com"
  End If

  'Choose whether CC/BCC recipient
  Set objRecip = Item.Recipients.Add(strBcc)
  objRecip.Type = olBCC

  'Resolve it?
  objRecip.Resolve

  'Clear the recipient
  Set objRecip = Nothing

End Sub