Question

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

我发现还有另一个VBA脚本，当用户点击＆＃34;发送＆＃34;时，会自动为所有外发电子邮件添加BCC地址而无需用户干预。 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

我想要做的是修改此脚本，以便根据用户用来发送电子邮件的WHICH电子邮件帐户更改添加的BCC地址。

例如：

If oMail.AccountThatImSendingFrom = "myself@privateemail.com" Then

    strBcc = "myaccount@gmail.com"

ElseIf oMail.AccountThatImSendingFrom = "myself@company.com" Then

    strBcc = "HM@company.com"

EndIf

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

我尝试过广泛搜索，但似乎无法找到一个可以调整的好例子。

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

任何人都可以帮助我或指出我正确的方向吗？

安德鲁

Answer 1

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

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

使用VBA创建规则以在外发Outlook电子邮件中添加BCC地址，具体取决于所使用的帐户

1 个答案: