Views

Excel Tips - 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:

"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: VBA, e-mail, send, Excel

Tags: , , ,

Nenhum comentário:

Postar um comentário

Assinar: Postar comentários (Atom)
diHITT - Notícias