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
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 .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.
.com
