使用VBA創建一個規則，以在傳出的Outlook電子郵件中添加密件抄送地址，具體取決於所使用的帳戶

Question

在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

我想做的就是修改此腳本，以便它可以根據用戶用來發送電子郵件的WHICH電子郵件帳戶更改添加的密件抄送地址。

例如：

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

我嘗試了廣泛的搜索，但是似乎找不到可以調整的好例子。

還有另外一個代碼示例在這里 ，我只是不能設法正確讀取-可能是因為所有的嵌入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