none
VBA Cópia Oculta - Diversas contas configuradas RRS feed

  • Pergunta

  • Pessoal, bom dia.

    Tenho uma VBA configurada no Outlook 2013 para cópia oculta de 2 endereços diferentes e funciona perfeitamente.

    Só que agora surgiu a necessidade de alterar a regra para que ela seja executada em apenas uma conta.

    Exemplo: Tenho 2 contas configuradas no mesmo perfil:

    email1@dominio.com

    email2@dominio.com


    Eu quero que a regra seja executada apenas no email1.

    Não to sabendo criar o if (acredito que seja isso).

    Poderiam me ajudar?

    Segue a regra que tenho aqui:

    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 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"

    '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

    'Preenchendo as variáveis com os e-mails que receberao as copias ocultas'
    Copia2 = "email2@dominio.com.br"

    'Rotina para sempre enviar copia automatica para o email 2 (copia2)'
        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
        End If
    Set objRecip = Nothing
    Set msg = Nothing
    End Sub


    • Editado Rodrigorqs sexta-feira, 8 de dezembro de 2017 13:24 Está configurado em 2 contas não 3 como disse antes.
    sexta-feira, 8 de dezembro de 2017 13:23

Todas as Respostas

  • 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