Cópia Oculta Automatico no Outlook - VBA

Question

Prezados, necessito de um auxilio:

Tenho o Outlook configurado com duas contas de e-mail. Para todo o e-mail enviado, desejo enviar uma cópia oculta para 2 destinatários diferentes, porém isso será feito apenas para uma das contas configuradas neste Outlook.

Consegui o seguinte: (mas não supriu minha necessidade atual)

Function FindParentMessage(msg As Outlook.MailItem) _
           As Outlook.MailItem
    Dim strFind As String
    Dim strIndex As String
    Dim fld As Outlook.MAPIFolder
    Dim itms As Outlook.Items
    Dim itm As Outlook.MailItem
    On Error Resume Next
    strIndex = Left(msg.ConversationIndex, _
                    Len(msg.ConversationIndex) - 10)
    Set fld = Application.Session.GetDefaultFolder(olFolderInbox)
    strFind = "[ConversationTopic] = " & _
              Chr(34) & msg.ConversationTopic & Chr(34)
    Set itms = fld.Items.Restrict(strFind)
    Debug.Print itms.Count
    For Each itm In itms
        If itm.ConversationIndex = strIndex Then
            Debug.Print itm.To
            Set FindParentMessage = itm
            Exit For
        End If
    Next
    Set fld = Nothing
    Set itms = Nothing
    Set itm = Nothing
End Function

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

Dim objRecip As Recipient
Dim strMsg As String
Dim Copia1 As String
Dim Copia2 As String
Dim Copia3 As String
Dim res As Integer
Dim msg As MailItem
On Error Resume Next

Set msg = FindParentMessage(Application.ActiveInspector.CurrentItem)
If Not msg Is Nothing Then
    msg.Display
End If

'Preenchendo as variáveis com os e-mails que receberao as copias ocultas
Copia1 = "[e-mail]"
Copia2 = "[e-mail]"
'Copia3 = "[e-mail]"

'Rotina para sempre enviar copia automatica para o email 1 (copia1)
    Set objRecip = Item.Recipients.Add(Copia1)
    objRecip.Type = olBCC
    objRecip.Resolve
    If Not objRecip.Resolve Then
        strMsg = "Could not resolve the Bcc recipient. " & "Do you want to send the message?"
        res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, "Could Not Resolve Bcc")
        If res = vbNo Then
            Cancel = True
        End If
    End If

'Rotina para sempre enviar copia automatica para o email 2 (copia 2)
    Set objRecip = Item.Recipients.Add(Copia2)
    objRecip.Type = olBCC
    objRecip.Resolve
    If Not objRecip.Resolve Then
        strMsg = "Could not resolve the Bcc recipient. " & "Do you want to send the message?"
        res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, "Could Not Resolve Bcc")
        If res = vbNo Then
            Cancel = True
        End If
    
    'Rotina para sempre enviar copia automatica para o email 3 (copia 3)
  '  Set objRecip = Item.Recipients.Add(Copia3)
   ' objRecip.Type = olBCC
    'objRecip.Resolve
    'If Not objRecip.Resolve Then
     '   strMsg = "Could not resolve the Bcc recipient. " & "Do you want to send the message?"
      '  res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, "Could Not Resolve Bcc")
       ' If res = vbNo Then
        '    Cancel = True
        'End If
    
    End If
Set objRecip = Nothing
Set msg = Nothing
End Sub

Conseguem me auxilar??

Answer 1

Boa tarde a todos.

Estou com problema igual, já enho o código pronto, mas tb tenho 2 contas configuradas no Outlook e quero que a regra seja executada apenas numa conta. É possível?

Answer 2

Achei um post na web que resolveu meu problema
Fica a dica aqui pro pessoal

Eu acrescentei esse código antes do que eu postei:

Sub Which_Account_Number()
    Dim OutApp As Outlook.Application
    Dim I As Long
    Set OutApp = CreateObject("Outlook.Application")
    For I = 1 To OutApp.Session.Accounts.Count
        MsgBox OutApp.Session.Accounts.Item(I) & " : This is account number " & I
    Next I
End Sub

Sub Mail_small_Text_Change_Account()
    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    Dim strbody As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(olMailItem)

    strbody = "Hi there" & vbNewLine & vbNewLine & _
              "This is line 1" & vbNewLine & _
              "This is line 2" & vbNewLine & _
              "This is line 3" & vbNewLine & _
              "This is line 4"

    On Error Resume Next
    With OutMail
        .To = "[e-mail]"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .Body = strbody

        .SendUsingAccount = OutApp.Session.Accounts.Item(1)

        .Send
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub