none
Cópia Oculta Automatico no Outlook - VBA RRS feed

  • Pergunta

  • 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 = "email1@dominio.com"
    Copia2 = "emial2@domio.com"
    'Copia3 = "email3@dominio.com"

    '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??

    • Editado Jessiksabino sexta-feira, 3 de outubro de 2014 12:54
    • Movido welington jr terça-feira, 12 de dezembro de 2017 18:42 forum certo
    quinta-feira, 2 de outubro de 2014 15:48

Todas as Respostas

  • 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?

    terça-feira, 12 de dezembro de 2017 17:49
  • 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 = "email1@dominio.com"
            .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

    terça-feira, 12 de dezembro de 2017 18:36