✔ Programação GLOBAL®: VBA Outlook - Envie todas as suas mensagens por e-mails como Bcc, automaticamente.

| Blog Office VBA | Blog Excel | Blog Access |

O MS Outlook tem uma regra quando enviamos mensagens para outra pessoa como Cc, mas não há nada equivalente para mensagens enviadas como BCC (ou CCo, Oculta).

Utilizaremos o evento Application.ItemSend, que será acionado quando um usuário for enviar uma mensagem.

A versão ideal para se fazer isso é a partir do MS Outlook 2003. Ela usa objetos exclusivamente Outlook e inclui manipulação de erro para evitar problemas com um endereço inválido Bcc.

Ela usa objetos exclusivamente MS Outlook e inclui manipulação de erro para evitar problemas com um endereço inválido Bcc.

Coloque esse código VBA no módulo interno de ThisOutlookSession:

1ª Versão:

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 = "bernardess@gmail.com"

   Set objRecip = Item.Recipients.Add(strBcc)

   objRecip.Type = olBCC

   If Not objRecip.Resolve Then

   strMsg = "Não posso enviar esta mensagem oculta. " & _

   "Deseja continuar enviando a mensagem?"

   res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, _

   "Não posso enviar esta mensagem oculta.")

   If res = vbNo Then

   Cancel = True

   End If

   End If

   Set objRecip = Nothing

End Sub

A razão pela qual este método não é adequado para as versões anteriores do MS Outlook 2003 é porque ele dispara um alerta de segurança devido ao uso do Recipients.Add.

Você pode evitar avisos de segurança, simplesmente definindo a propriedade Item.Bcc para o endereço desejado, mas terá dois problemas. Primeiro, iria retirar os destinatários Bcc que o usuário já tivesse adicionado. Além disso, em algumas configurações do MS Outlook, mesmo se você usar um endereço SMTP apropriado, obteria um erro, e o MS Outlook  não enviaria a mensagem.

2ª Versão:

Esta versão utiliza a mesma técnica básica da 1ª, apenas adiciona a biblioteca de terceiros Outlook Redemption para evitar avisos de segurança das versões anteriores ao MS Outlook 2003 e, caso o beneficiário não possa ser resolvido, para mostrar ao usuário uma caixa de diálogo de resolução dos nomes.

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

   ' Requires a reference to

   ' the SafeOutlook library (Redemption.dll)

   Dim objMe As Redemption.SafeRecipient

   Dim sMail As Redemption.SafeMailItem

   On Error Resume Next



   Set sMail = CreateObject("Redemption.SafeMailItem")

   Item.Save

   sMail.Item = Item

   Set objMe = sMail.Recipients.Add ("bernardess@gmail.com")

   objMe.Type = olBCC

   If Not objMe.Resolve(True) Then

   Cancel = True

   End If



   Set objMe = Nothing

   Set sMail = Nothing

End Sub