✔ Programação GLOBAL®: VBA Excel: Enviando e-mails a partir do Excel

Estender certa praticidade aos nossos clientes, facilitando-lhes o dia-a-dia, é um prazer para nós desenvolvedores, certo? Abaixo replico um post antigo, e agora ampliado, com uma funcionalidade que visa facilitar o compartilhamento dos nossos BIs (Business Information), BSCs, Dashboards, Scorecards ou mesmo dos relatórios e gráficos que estão contidos em nossos MISs. Como? Enviando-os por e-mail.

Sugiro algumas aplicabilidades práticas para a utilização do envio automatizado e e-mails:

: : Sabe quando você está responsável por consolidar diversas planilhas em uma só e o pessoal que precisa enviar-lhe as planilhas (ou disponibilizá-las em algum lugar) não o fazem? então, automatize a cobrança por e-mail

: : Ao invés de gastar tempo reunindo todas as planilhas após o fechamento e enviá-las uma-a-uma a todos os gestores, reúna os dados em um só recipiente, crie uma lista de quem receberá as planilhas e pronto!

A primeira opção utiliza o método SEND, e serve como incentivo a sua pesquisa e estudo.

Sub SendPlanNow()
    ActiveWorkbook.SendMail _

     Recipients:="bernardess@gmail.com", _

    Subject:="Enviando e-mail da  aplicação Excel em: " & Format(Date, "dd/mm/yyyy")
End  Sub

Outras necessidades vão se desenrolando com o passar do tempo, como por exemplo copiar a pasta ativa (ActiveSheet), envindo a planilha em seguida:

Sub Send1Sheet_ActiveWorkbook()

' Criando uma nova planilha (workbook) contendo um Sheet, e enviando-a

como um arquivo anexado.

ThisWorkbook.Sheets(1).Copy

With ActiveWorkbook

.SendMail Recipients:="bernardess@gmail.com", _

Subject:="Tente contatar-me em: " & Format(Date, "dd/mmm/yy")

.Close SaveChanges:=False

End With

End Sub

Outro método que pode ser usado é o Método de Roteirização, este encaminha a pasta de trabalho (worksheet), a partir de uma lista seguindo o roteiro atual, isto nos permite especificar inúmeros destinatários.

Sub RoutingActwBook()

With ActiveWorkbook

Let .HasRoutingSlip = True

With .RoutingSlip

Let .Delivery = xlOneAfterAnother

Let .Recipients = Array("bernardess@gmail.com", "inanyplace01@gmail.com", "inanyplace02@gmail.com")

Let .Subject = "Por favor, dê atenção a este relatório"

'Let.Message = ""

End With

.Route

End With

End Sub

Um outro problema comum encontrado em diversos códigos onde se faz citação ao envio de e-mails de modo automatizado é a aparição de mensagens similares a:
projeto mas nesta versão existe uma mensagem de alerta que é exibida a cada envio:

"A program is trying to automatically send e-mail..."
"Um programa está tentando enviar..."

Como eliminar de vez esta constante mensagem de exibição?

Bem, a solução não está no MS Excel, neste caso, pois esta solução pode ser implementada em qualquer um dos produtos do MS Office.

Crie um novo módulo no MS Outlook e cole o código abaixo (Agradecimentos antecipados ao Waine Phillips, dono da solução):

Public Function FnSendMailSafe(strTo As String, _

strCC As String, _

strBCC As String, _

strSubject As String, _

strMessageBody As String, _

Optional strAttachments) As Boolean

On Error GoTo ErrorHandler:

Dim MAPISession As Outlook.NameSpace

Dim MAPIFolder As Outlook.MAPIFolder

Dim MAPIMailItem As Outlook.MailItem

Dim oRecipient As Outlook.Recipient

Dim TempArray() As String

Dim varArrayItem As Variant

Dim strEmailAddress As String

Dim strAttachmentPath As String

Dim blnSuccessful As Boolean

'Obtendo o MAPI do objeto NameSpace

Set MAPISession = Application.Session

If Not MAPISession Is Nothing Then

'Logando-se na sessão MAPI

MAPISession.Logon , , True, False

'Criando um ponteiro na pasta Outbox

Set MAPIFolder = MAPISession.GetDefaultFolder(olFolderOutbox)

If Not MAPIFolder Is Nothing Then

' Criando um novo item de e-mail item na pasta "Outbox"

Set MAPIMailItem = MAPIFolder.Items.Add(olMailItem)

If Not MAPIMailItem Is Nothing Then

With MAPIMailItem

'Criando um novo recipiente para TO

Let TempArray = Split(strTo, ";")

For Each varArrayItem In TempArray

Let strEmailAddress = Trim(varArrayItem)

If Len(strEmailAddress) > 0 Then

Set oRecipient = .Recipients.Add(strEmailAddress)

Let oRecipient.Type = olTo

Set oRecipient = Nothing

End If

Next varArrayItem

'Criando um recipiente para CC

Let TempArray = Split(strCC, ";")

For Each varArrayItem In TempArray

Let strEmailAddress = Trim(varArrayItem)

If Len(strEmailAddress) > 0 Then

Set oRecipient = .Recipients.Add(strEmailAddress)

Let oRecipient.Type = olCC

Set oRecipient = Nothing

End If

Next varArrayItem

'Criando recipiente para BCC

Let TempArray = Split(strBCC, ";")

For Each varArrayItem In TempArray

Let strEmailAddress = Trim(varArrayItem)

If Len(strEmailAddress) > 0 Then

Set oRecipient = .Recipients.Add(strEmailAddress)

Let oRecipient.Type = olBCC

Set oRecipient = Nothing

End If

Next varArrayItem

'Configurado a mensagem do SUBJECT

Let .Subject = strSubject

'Configurando a mensagem do corpo od e-mail (em HTML ou texto)

If StrComp(Left(strMessageBody, 6), "<HTML>", vbTextCompare) = 0 Then

Let .HTMLBody = strMessageBody

Else

Let .Body = strMessageBody

End If

'Adicionando qualquer anexo especificado

'Let TempArray = strAttachments

For Each varArrayItem In strAttachments

Let strAttachmentPath = Trim(varArrayItem)

If Len(strAttachmentPath) > 0 Then

.Attachments.Add strAttachmentPath

End If

Next varArrayItem

.Send

Set MAPIMailItem = Nothing

End With

End If

Set MAPIFolder = Nothing

End If

MAPISession.Logoff

End If

Let blnSuccessful = True

ExitRoutine:

Set MAPISession = Nothing

Let FnSendMailSafe = blnSuccessful

Exit Function

ErrorHandler:

MsgBox "Occoreu um erro na função VBA FnSendMailSafe()" & vbCrLf & vbCrLf & _

"Nº do erro: " & CStr(Err.Number) & vbCrLf & _

"Descrição do erro: " & Err.Description, vbApplicationModal + vbCritical

Resume ExitRoutine

End Function

Já no MS Excel (ou qualquer outro produto do MS Office), cole o código abaixo:Chame essa função com os parâmetros da mensagem.
No parâmetro TO (Para) e CC é só separar os e-mails com ;[ponto-e-vírgula], e os anexos precisarão estar numa matriz.

Function SendMail (para As String, cc As String, assunto As String, mensagem As String, Anexos) As Boolean

'enviar e-mail via Outlook

Dim objOutlook As Object ' Note: Must be late-binding.

Dim objNameSpace As Object

Dim objExplorer As Object

Dim blnSuccessful As Boolean

Dim blnNewInstance As Boolean

On Error Resume Next

Set objOutlook = GetObject(, "Outlook.Application")

On Error GoTo 0

If objOutlook Is Nothing Then

Set objOutlook = CreateObject("Outlook.Application")

Let blnNewInstance = True

Set objNameSpace = objOutlook.GetNamespace ("MAPI")

Set objExplorer = objOutlook.Explorers.Add (objNameSpace.Folders(1), 0)

objExplorer.CommandBars.FindControl(, 1695).Execute

objExplorer.Close

Set objNameSpace = Nothing

Set objExplorer = Nothing

End If

Let blnSuccessful = objOutlook.FnSendMailSafe (para, cc, "", assunto, mensagem, Anexos)

If blnNewInstance = True Then objOutlook.Quit

Set objOutlook = Nothing

Let EnviarEmail = blnSuccessful

End Function