Olá, pessoal, nessa postagem mostrarei para vocês um dos recursos que eu mais forneço para as áreas de negócio e tenho certeza que você também tem uma rotina dessa: envio recorrente de e-mails com uma mensagem “padronizada”, com pontos personalizáveis (cumprimentos, datas limites etc.) e com algum arquivo anexo. Aqui te darei 02 opções com o Excel + VBA: uma para pessoas mais conservadoras que gostam de verificar se tudo está certinho antes de disparar o e-mail e outra que automatiza até o envio, uma vez que a rotina é padrão e não há o que “se certificar” antes do envio.
1 – A Central de Notificação
A central de notificação é o ambiente que rodará o “robozinho”, nela você precisa ter um banco de cadastros com os nomes e e-mails das pessoas que receberão a notificação. É nessa aba que teremos a parte de “padronização com carinho”, que é onde haverá mensagens padronizadas, mas com os cumprimentos personalizados para mantermos a formalidade, mas também a padronização eficiência no processo. Sei que construir esse banco de dados parece trabalhoso e é, mas vale a pena porque será 1 vez só para algo que você usará de maneira recorrente. Dentro dessa central os botões para criar e criar e enviar estarão disponíveis.
Fique tranquilo, eu preparei um arquivo XLSM (Excel habilitado para macros) para que você preencha com os seus dados e utilize no dia a dia. Seu trabalho é enriquecer o arquivo com as suas informações mesmo e usar ao seu favor. No final da postagem você encontrará os códigos escritos mas também maneiras de receber os arquivos.
2 – Macro de Criar E-mail com Anexo | Lógica
A macro funciona assim: coleta os arquivos em PDF de uma pasta especificada por você no código. Ela olhará para o nome do arquivo e comparará com as informações contidas na central (coluna B) se der match ela constrói os e-mails com as demais informações da planilha. Ao final das criações uma mensagem aparece dizendo que está tudo pronto, analise e dispare.
Caso o que você costuma encaminhar é um arquivo Excel ou qualquer outra extensão, você pode mudar a extensão direto no código e se tiver dificuldades use o chatgpt para fazer isso. É super rápido. Basta colar o código e digitar “a extensão do arquivo que eu uso não é PDF é tal” então ele modifica o código para você.
3 – Macro de Criar e Enviar e-mail com Anexo | Lógica
Segue a mesma lógica, a diferença é que ele dispara e retorna uma mensagem dizendo que terminou e quantos e-mails foram enviados.
Os arquivos estão disponibilizados de maneira escrita neste post. Lembrem-se de alterar o endereço da pasta que conterá os arquivos a serem anexos e editar também o caminho em que o arquivo xlsm ficará salvo.
Se quiser que eu os envie (arquivo xlsm pronto com macros atribuídas + arquivos txt) basta comentar o seu endereço de e-mail que eu os encaminho.
Faça bom uso 😀
Obrigada!
KHASHIMOTO
A – Código – Criar E-mails com Anexo
Option Explicit
Public Sub CriarEmailsComAnexo()
Dim folderPath As String
Dim wbPath As String
Dim wbName As String
Dim wb As Workbook
Dim sht As Worksheet
Dim fileName As String
Dim fileNoExt As String
Dim olApp As Object
Dim olMail As Object
Dim found As Range
Dim rowFound As Long
Dim toAddr As String, ccAddr As String, subj As String, bodyText As String
Dim openedByMacro As Boolean
Dim filesCriados As Long
Dim bodyHTML As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False
folderPath = "COLOQUE O ENDEREÇO DA PASTA QUE ESTARÃO OS ARQUIVOS QUE SERÃO ANEXADOS ENTRE AS ASPAS DUPLAS"
wbPath = "COLOQUE O CAMINHO DO ARQUIVO QUE CONTÉM O ROBÔ ENTRE AS ASPAS DUPLAS. CAMINHO COMPLETO INCLUINDO A EXTENSÃO DO ARQUIVO. APERTE O BOTÃO DIREITO DO MOUSE EM CIMA DO ARQUIVO E CLIQUE EM COPIAR CAMINHO"
wbName = Dir(wbPath)
' Checar se workbook já está aberto
openedByMacro = False
If IsWorkbookOpen(wbName) Then
Set wb = Workbooks(wbName)
Else
Set wb = Workbooks.Open(wbPath, ReadOnly:=True)
openedByMacro = True
End If
Set sht = wb.Worksheets("Central de Notificação")
' Iniciar Outlook (binding tardio)
Set olApp = CreateObject("Outlook.Application")
If olApp Is Nothing Then
MsgBox "Outlook não foi iniciado. Verifique se o Outlook está instalado/configurado.", vbExclamation
GoTo Cleanup
End If
' Garantir barra no final do caminho
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
' Percorrer PDFs na pasta (não recursivo)
fileName = Dir(folderPath & "*.pdf")
filesCriados = 0
Do While fileName <> ""
' retirar extensão
If InStrRev(fileName, ".") > 0 Then
fileNoExt = Left(fileName, InStrRev(fileName, ".") - 1)
Else
fileNoExt = fileName
End If
' Procurar na coluna B (ajustado conforme seu código)
Set found = sht.Columns("B").Find(What:=Trim(fileNoExt), LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If found Is Nothing Then
Set found = sht.Columns("B").Find(What:=Trim(fileName), LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
End If
If Not found Is Nothing Then
rowFound = found.Row
toAddr = Trim(CStr(sht.Cells(rowFound, "G").Value))
ccAddr = Trim(CStr(sht.Cells(rowFound, "H").Value))
subj = Trim(CStr(sht.Cells(rowFound, "E").Value))
bodyText = CStr(sht.Cells(rowFound, "F").Value)
' Preparar HTML do corpo (converte quebras de linha e mantém <b> tags)
bodyHTML = PrepareHTMLBody(bodyText)
' Criar e-mail e anexar o PDF
Set olMail = olApp.CreateItem(0) ' olMailItem
With olMail
If Len(toAddr) > 0 Then .To = toAddr
If Len(ccAddr) > 0 Then .cc = ccAddr
.Subject = subj
.Attachments.Add folderPath & fileName
.Display ' exibe para carregar assinatura do Outlook
End With
' Inserir o HTML antes da assinatura existente
On Error Resume Next
olMail.HTMLBody = bodyHTML & olMail.HTMLBody
On Error GoTo ErrHandler
filesCriados = filesCriados + 1
End If
fileName = Dir() ' próximo arquivo
Loop
MsgBox "E-mails prontos. Favor conferir e disparar", vbInformation
Cleanup:
' Fechar workbook se foi aberto pela macro
On Error Resume Next
If openedByMacro Then wb.Close SaveChanges:=False
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
Application.ScreenUpdating = True
MsgBox "Ocorreu um erro: " & Err.Number & " - " & Err.Description, vbExclamation
Resume Cleanup
End Sub
Private Function PrepareHTMLBody(s As String) As String
' Converte quebras de linha para e mantém tags ... para serem renderizadas como negrito
Dim t As String
If Len(s) = 0 Then
PrepareHTMLBody = ""
Exit Function
End If
' Normalizar quebras de linha
t = Replace(s, vbCrLf, "<br>")
t = Replace(t, vbCr, "<br>")
t = Replace(t, vbLf, "<br>")
' Se desejar tratar caracteres especiais (&, <, >) com mais segurança,
' seria necessário escapar e depois restaurar as tags <b>...</b>.
' Aqui assumimos que as únicas tags HTML usadas intencionalmente são <b> e </b>.
' Retornar encapsulado em tag body (opcional)
PrepareHTMLBody = "<div style=""font-family:Calibri, Arial, sans-serif; font-size:11pt;"">" & t & "</div>"
End Function
' Função para checar se um workbook (pelo nome do arquivo) está aberto
Private Function IsWorkbookOpen(wbName As String) As Boolean
Dim w As Workbook
On Error Resume Next
For Each w In Workbooks
If StrComp(w.Name, wbName, vbTextCompare) = 0 Then
IsWorkbookOpen = True
Exit Function
End If
Next w
IsWorkbookOpen = False
On Error GoTo 0
End Function
B – Criar e Enviar E-mails com Anexo
Option Explicit
Public Sub CriarEmailsComAnexoEnviar()
Dim folderPath As String
Dim wbPath As String
Dim wbName As String
Dim wb As Workbook
Dim sht As Worksheet
Dim fileName As String
Dim fileNoExt As String
Dim olApp As Object
Dim olMail As Object
Dim found As Range
Dim rowFound As Long
Dim toAddr As String, ccAddr As String, subj As String, bodyText As String
Dim openedByMacro As Boolean
Dim filesEnviados As Long
Dim bodyHTML As String
Dim signatureHTML As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False
folderPath = "COLOQUE O ENDEREÇO DA PASTA QUE ESTARÃO OS ARQUIVOS QUE SERÃO ANEXADOS ENTRE AS ASPAS DUPLAS"
wbPath = "COLOQUE O CAMINHO DO ARQUIVO QUE CONTÉM O ROBÔ ENTRE AS ASPAS DUPLAS. CAMINHO COMPLETO INCLUINDO A EXTENSÃO DO ARQUIVO. APERTE O BOTÃO DIREITO DO MOUSE EM CIMA DO ARQUIVO E CLIQUE EM COPIAR CAMINHO"
wbName = Dir(wbPath)
' Checar se workbook já está aberto
openedByMacro = False
If IsWorkbookOpen(wbName) Then
Set wb = Workbooks(wbName)
Else
Set wb = Workbooks.Open(wbPath, ReadOnly:=True)
openedByMacro = True
End If
Set sht = wb.Worksheets("Central de Notificação")
' Iniciar Outlook (binding tardio)
Set olApp = CreateObject("Outlook.Application")
If olApp Is Nothing Then
MsgBox "Outlook não foi iniciado. Verifique se o Outlook está instalado/configurado.", vbExclamation
GoTo Cleanup
End If
' Garantir barra no final do caminho
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
' Percorrer PDFs na pasta (não recursivo)
fileName = Dir(folderPath & "*.pdf")
filesEnviados = 0
Do While fileName <> ""
' retirar extensão
If InStrRev(fileName, ".") > 0 Then
fileNoExt = Left(fileName, InStrRev(fileName, ".") - 1)
Else
fileNoExt = fileName
End If
' Procurar na coluna B (ajustado conforme seu código)
Set found = sht.Columns("B").Find(What:=Trim(fileNoExt), LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If found Is Nothing Then
Set found = sht.Columns("B").Find(What:=Trim(fileName), LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
End If
If Not found Is Nothing Then
rowFound = found.Row
toAddr = Trim(CStr(sht.Cells(rowFound, "G").Value))
ccAddr = Trim(CStr(sht.Cells(rowFound, "H").Value))
subj = Trim(CStr(sht.Cells(rowFound, "E").Value))
bodyText = CStr(sht.Cells(rowFound, "F").Value)
' Preparar HTML do corpo (converte quebras de linha e mantém <b> tags)
bodyHTML = PrepareHTMLBody(bodyText)
' Criar e-mail, carregar assinatura, inserir HTML e enviar
Set olMail = olApp.CreateItem(0) ' olMailItem
With olMail
If Len(toAddr) > 0 Then .To = toAddr
If Len(ccAddr) > 0 Then .cc = ccAddr
.Subject = subj
.Attachments.Add folderPath & fileName
' Exibir rapidamente para carregar assinatura no HTMLBody
.Display
' Aguarda 1 segundo para a assinatura carregar
Application.Wait Now + TimeValue("0:00:01")
DoEvents
On Error Resume Next
signatureHTML = .HTMLBody
On Error GoTo ErrHandler
' Inserir nosso HTML antes da assinatura e enviar
.HTMLBody = bodyHTML & signatureHTML
.Send
End With
filesEnviados = filesEnviados + 1
End If
fileName = Dir() ' próximo arquivo
Loop
MsgBox "E-mails enviados. Total: " & filesEnviados, vbInformation
Cleanup:
' Fechar workbook se foi aberto pela macro
On Error Resume Next
If openedByMacro Then wb.Close SaveChanges:=False
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
Application.ScreenUpdating = True
MsgBox "Ocorreu um erro: " & Err.Number & " - " & Err.Description, vbExclamation
Resume Cleanup
End Sub
Private Function PrepareHTMLBody(s As String) As String
' Converte quebras de linha para e mantém tags ... para serem renderizadas como negrito
Dim t As String
If Len(s) = 0 Then
PrepareHTMLBody = ""
Exit Function
End If
' Normalizar quebras de linha
t = Replace(s, vbCrLf, "<br>")
t = Replace(t, vbCr, "<br>")
t = Replace(t, vbLf, "<br>")
' Retornar encapsulado em tag div com fonte adequada
PrepareHTMLBody = "<div style=""font-family:Calibri, Arial, sans-serif; font-size:11pt;"">" & t & "</div><br>"
End Function
' Função para checar se um workbook (pelo nome do arquivo) está aberto
Private Function IsWorkbookOpen(wbName As String) As Boolean
Dim w As Workbook
On Error Resume Next
For Each w In Workbooks
If StrComp(w.Name, wbName, vbTextCompare) = 0 Then
IsWorkbookOpen = True
Exit Function
End If
Next w
IsWorkbookOpen = False
On Error GoTo 0
End Function
Y-DATAFIN 
Deixe um comentário