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
Sub Send1Sheet_ActiveWorkbook()' Criando uma nova planilha (workbook) contendo um Sheet, e enviando-acomo um arquivo anexado.ThisWorkbook.Sheets(1).CopyWith ActiveWorkbook
.SendMail Recipients:="bernardess@gmail.com", _Subject:="Tente contatar-me em: " & Format(Date, "dd/mmm/yy").Close SaveChanges:=FalseEnd 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 ActiveWorkbookLet .HasRoutingSlip = TrueWith .RoutingSlip
Let .Delivery = xlOneAfterAnotherLet .Subject = "Por favor, dê atenção a este relatório"'Let.Message = ""End With.Route
End WithEnd 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.
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.NameSpaceDim MAPIFolder As Outlook.MAPIFolderDim MAPIMailItem As Outlook.MailItemDim oRecipient As Outlook.RecipientDim TempArray() As StringDim varArrayItem As VariantDim strEmailAddress As StringDim strAttachmentPath As StringDim blnSuccessful As Boolean'Obtendo o MAPI do objeto NameSpaceSet MAPISession = Application.Session
If Not MAPISession Is Nothing Then'Logando-se na sessão MAPIMAPISession.Logon , , True, False'Criando um ponteiro na pasta OutboxSet 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 ThenWith MAPIMailItem
'Criando um novo recipiente para TOLet TempArray = Split(strTo, ";")For Each varArrayItem In TempArrayLet strEmailAddress = Trim(varArrayItem)
If Len(strEmailAddress) > 0 Then
Set oRecipient = .Recipients.Add(strEmailAddress)
Let oRecipient.Type = olToSet oRecipient = NothingEnd IfNext varArrayItem'Criando um recipiente para CCLet 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 = olCCSet oRecipient = NothingEnd If
Next varArrayItem'Criando recipiente para BCCLet 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 = olBCCSet oRecipient = NothingEnd IfNext varArrayItem'Configurado a mensagem do SUBJECTLet .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 = strMessageBodyElse
Let .Body = strMessageBodyEnd If
'Adicionando qualquer anexo especificado
'Let TempArray = strAttachmentsFor Each varArrayItem In strAttachmentsLet strAttachmentPath = Trim(varArrayItem)If Len(strAttachmentPath) > 0 Then.Attachments.Add strAttachmentPathEnd IfNext varArrayItem.Send
Set MAPIMailItem = NothingEnd With
End IfSet MAPIFolder = NothingEnd If
MAPISession.LogoffEnd If
Let blnSuccessful = TrueExitRoutine:Set MAPISession = NothingLet FnSendMailSafe = blnSuccessfulExit FunctionErrorHandler: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 + vbCriticalResume 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.
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 OutlookDim objOutlook As Object ' Note: Must be late-binding.Dim objNameSpace As ObjectDim objExplorer As ObjectDim blnSuccessful As BooleanDim blnNewInstance As Boolean
On Error Resume NextSet objOutlook = GetObject(, "Outlook.Application")On Error GoTo 0If objOutlook Is Nothing ThenSet objOutlook = CreateObject("Outlook.Application")Let blnNewInstance = TrueSet objNameSpace = objOutlook.GetNamespace ("MAPI")Set objExplorer = objOutlook.Explorers.Add (objNameSpace.Folders(1), 0)objExplorer.CommandBars.FindControl(, 1695).ExecuteobjExplorer.CloseSet objNameSpace = NothingSet objExplorer = NothingEnd If
Let blnSuccessful = objOutlook.FnSendMailSafe (para, cc, "", assunto, mensagem, Anexos)If blnNewInstance = True Then objOutlook.QuitSet objOutlook = NothingLet EnviarEmail = blnSuccessfulEnd Function
Tags: Bernardes, e-mail, send, Excel