Используя VBA, создайте правило для добавления адреса BCC в исходящую электронную почту Outlook, в зависимости от используемой учетной записи.

Question

В Stackru найден оригинальный сценарий, который касается использования сценария VBA в Outlook, чтобы условно запретить Outlook отправлять электронную почту на основании адресов получателей и получателей.

Я обнаружил еще один сценарий VBA, который автоматически добавляет адрес 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 = "[e-mail]"
    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

То, что я хотел бы сделать, это изменить этот скрипт так, чтобы он изменил добавляемый адрес BCC в зависимости от того, какую учетную запись электронной почты использовал пользователь для отправки электронного письма.

Например:

If oMail.AccountThatImSendingFrom = "[e-mail]" Then

    strBcc = "[e-mail]"

ElseIf oMail.AccountThatImSendingFrom = "[e-mail]" Then

    strBcc = "[e-mail]"

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

Я много пробовал искать, но просто не могу найти хороший пример, который я могу настроить.

Здесь есть еще один пример кода, который я просто не могу прочитать правильно - возможно, из-за всех встроенных операторов 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 = "[e-mail]" 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 = "[e-mail]" Then
      strBcc = ""
  End If

  'If sending using your second account
  If strSendUsingAccount = "[e-mail]" Then
      strBcc = "[e-mail]"
  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