O Outlook tem uma regra para envia email automaticamente Cc para outra pessoa em mensagens de saída, mas não para enviar como cópia oculta (Cco). Então aí vai uma diga para quem deseja enviar emails com cópia oculta automaticamente.
Para configurá-lo, siga os passos:
5 – Abra o Outlook e vá em Opções / Central de Confiabilidade / Configurações da Central de Confiabilidade / Configurações do Macro. Marque a opção Habilitar todas as macros e clique em Ok e feche o Outlook.
8 – Selecione o nome do certificado criado anteriormente e clique em OK e Ok.
Para configurá-lo, siga os passos:
1 - Abra o Outlook e pressione a tecla Alt + F11 para abrir o Editor VBA.
2 – Clique em ThisOutlookSession e cole o código VBA abaixo:
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
Cancel As Boolean)
Dim objRecip As Recipient
Dim strMsg As String
Dim res As Integer
Dim strBcc As String
On Error Resume Next
‘ #### EMAIL CÓPIA OCULTA ####
strBcc = “emailcopiaoculta@seudominio.com.br”
strBcc = “emailcopiaoculta@seudominio.com.br”
Set objRecip = Item.Recipients.Add(strBcc)
objRecip.Type = olBCC
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
objRecip.Type = olBCC
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
End Sub
End Sub
3 – Na strBcc do código acima altere o email entre ” “, para o endereço de email que você deseja enviar a cópia oculta. Feche e Outlook e
4 – Após Fechar o Outlook será apresentado uma tela perguntando se você deseja salvar o projeto do VBA. Clique em Sim.
4 – Após Fechar o Outlook será apresentado uma tela perguntando se você deseja salvar o projeto do VBA. Clique em Sim.
6 – Agora vai no menu Iniciar do Windows / Todos os Programas / Microsoft Office / Ferramentas do Microsoft Office e clique em Certificado Digital para Projetos do VBA.
Conforme a tela abaixo dê um nome para o certificado e clique em Ok.
7 – Abra novamente o Outlook e pressione a tecla Alt+F11. Será aberto novamente o Editor do VBA. Vá agora em Ferramentas / Assinatura Digital. Clique em Escolher .
8 – Selecione o nome do certificado criado anteriormente e clique em OK e Ok.
9 – Agora feche o Outlook. Será apresentado uma mensagem novamente pedindo para salvar o projeto VBA. Clique em Sim.
Pronto! Agora você já pode fazer o teste de envio e ver que todas as mensagens que você enviar, serão enviadas cópias em oculto para o destinatário configurado.
Bom dia.
ResponderExcluiracabei de fazer o teste e deu erro...retirei o que estava entre os jogos da velha e mesmo assim não funcionou - ‘ #### EMAIL CÓPIA OCULTA #### .
poderia me ajudar? preciso apenas que todos os emails enviados e respondidos vão com copia oculta para um outro a minha escolha.
Obrigado.
estão faltando duas linhas no projeto do post.
ExcluirAbaixo projeto corrigido. Eu fiz e deu certinho!!
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
' #### USER OPTIONS ####
' address for Bcc -- must be SMTP address or resolvable
' to a name in the address book
strBcc = "someone@somewhere.dom"
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
o erro que dá é quando vou enviar qualquer email aparece erro sistaxe
ResponderExcluirSubstitua as aspas que você colou no código pelas aspas duplas digitadas pelo seu teclado. Elimine a linha de comentário ‘ #### EMAIL CÓPIA OCULTA ####. Deve funcionar.
ResponderExcluirConsigo enviar para mais de um e-mail?
ResponderExcluirTentei de tudo mas não deu certo
Tb tentei de tudo e não funcionou...aparece "ERRO SISTAXE"
ResponderExcluirAbaixo projeto VBA corrigido:
ResponderExcluirPrivate 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
' #### USER OPTIONS ####
' address for Bcc -- must be SMTP address or resolvable
' to a name in the address book
strBcc = "someone@somewhere.dom"
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
Esse deu certo aqui.
ExcluirQuem não achar o Certificado Digital para Projetos do VBA vai em C:\Program Files\Microsoft Office\root\Office16 (ou versão do office que tem instalado) e execute o SELFCERT.exe
Vlw.
Boa noite, consigo inserir um critério nesse código? Por exemplo que todo e-mail que for enviado com um determinado assunto envie automaticamente uma cópia oculta.
ResponderExcluirDesde já agradeço.