✔ VBA Dashboards Specialist®: Excel Tips - Enviando e-mails a partir do Excel

Acesse uma ENORME lista de Dashboards e Infográficos

Aprenda a detectar gráficos que precisam mudar

Dados ou Informações?

Dashboards - 8 Importantes características desejáveis

Dashboards e Infocharts - Diversas Visualizações de Dados

Diversos exemplos de Gráficos

Excel - DashMap - Mapa do Brasil

Key Performance Indicators - 7 Características desejáveis

MIS - Usufruindo a excelência na análise das suas Informações

O Melhor do Business Intelligence

Os 10 mandamentos do gerenciamento de projetos

Receba 3 Calendários Customizáveis de 2013 em Excel

Usando Gauges em Dashboards no MS Access

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:

"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