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

Tags: Bernardes, e-mail, send, Excel

André Luiz Bernardes

A&A® - Work smart, not hard.

VBA Blogs

  

bernardes@.com