#Code
Sub Envia_Email()
'Seleciona o intervalo de células na planilha ativa.
Application.DisplayAlerts = False 'desabilite o alerta
Sheets("Base filtrada").Select
Dim email_envio As Variant
email_envio = Range("AP2") 'e-mail para qual será enviado
descricao = Range("AQ2")
Set rngInicial = Range("R1")
rngInicial.Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
'https://stackoverflow.com/a/48496434/7690982
Dim rng As Range, cell As Range, HtmlContent As String, i As Long, j As Long
Set rng = Selection
'Debug.Print rng.Address 'Verifica os endereços da Seleção
HtmlContent = "<table>"
For i = rngInicial.Row To rngInicial.Row + rng.Rows.Count - 1
HtmlContent = HtmlContent & "<tr>"
For j = rngInicial.Column To rngInicial.Column + rng.Columns.Count - 1
HtmlContent = HtmlContent & "<td>" & Cells(i, j).Value & "</td>"
Next
HtmlContent = HtmlContent & "</tr>"
Next
HtmlContent = HtmlContent & "</table>"
'https://stackoverflow.com/a/15161351/7690982
Dim OApp As Object, OMail As Object
Set OApp = CreateObject("Outlook.Application")
Set OMail = OApp.CreateItem(0)
With OMail
.Display
End With
signature = OMail.HTMLbody
With OMail
Introducao = "Prezado, bom dia! <br> Seguem os extratos atualizados nas campanhas:" 'Texto Intro Corpo do e-mail
.To = email_envio
.Cc = "[email protected]" 'Quem será copiado
.Subject = "Extrato " & descricao 'Assunto do e-mail
'.Attachments.Add
.HTMLbody = Introducao & "<br>" & HtmlContent & "<br>"& signature
.Send
End With
Set OMail = Nothing
Set OApp = Nothing
Application.DisplayAlerts = True 'habilite o alerta
End Sub
Note: It is not recommended to use the .Select
and Selection
, there are other ways to accomplish this. See: How to avoid using Select in Excel VBA
#Explanation
###Outlook
Instead of:
' Mostrar o envelope na ActiveWorkbook.
ActiveWorkbook.EnvelopeVisible = True
With ActiveSheet.MailEnvelope
A Outlook object with Late Binding is created:
'https://stackoverflow.com/a/15161351/7690982
Dim OApp As Object, OMail As Object
Set OApp = CreateObject("Outlook.Application")
Set OMail = OApp.CreateItem(0)
With OMail
.Display
End With
###Signing
Then the default HTML Signature is used: signature = OMail.HTMLbody
###Create email and send
Then the e-mail is created and sent:
With OMail
Introducao = "Prezado, bom dia!. <br> Seguem os extratos atualizados nas campanhas:" 'Texto Intro Corpo do e-mail
.To = email_envio
.Cc = "[email protected]" 'Quem será copiado
.Subject = "Extrato " & descricao 'Assunto do e-mail
'.Attachments.Add 'Para inserir Anexos
.HTMLbody = Introducao & "<br>" & HtmlContent & "<br>" & signature
.Send
End With
###Create table
The table with contents is added with the following code:
'https://stackoverflow.com/a/48496434/7690982
Dim rng As Range, cell As Range, HtmlContent As String, i As Long, j As Long
Set rng = Selection
'Debug.Print rng.Address 'Verifica os endereços da Seleção
HtmlContent = "<table>"
For i = rngInicial.Row To rngInicial.Row + rng.Rows.Count - 1
HtmlContent = HtmlContent & "<tr>"
For j = rngInicial.Column To rngInicial.Column + rng.Columns.Count - 1
HtmlContent = HtmlContent & "<td>" & Cells(i, j).Value & "</td>"
Next
HtmlContent = HtmlContent & "</tr>"
Next
HtmlContent = HtmlContent & "</table>"
Where tab tags are added for each item in the Excel range that contains table data.
##EDIT to keep formatting:
To keep the formatting, the Bruin Ron Rangetohtml function can be used:
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
#Code
So instead of creating the table, the function can be called with:
HtmlContent = RangetoHTML(Selection)
And the HTML body can be built with:
.HTMLbody = Introducao & "<br>" & HtmlContent & "<br>" & signature
Daniel, thank you very much! However, in some of the cells that go to the email I have some conditional formatting. Have some way to keep formatting cells for email?
– Leonardo M. Pires
For example, copy as if it were an image and paste, or just keep the same formatting. Because there is a lighthouse in the cells at the end.
– Leonardo M. Pires
Example of headlamp: <50% = red and >50% = green. Keep as an image would copy exactly what is in the selected area and paste into the email body (as a print). However, either as image or just keeping the formatting would already solve the problem.
– Leonardo M. Pires
Daniel, thank you so much for your help. However, the macro still does not copy the lighthouse. The following is the lighthouse demonstration link in the old macro (which did not insert the signature): https://www.sendspace.com/filegroup/vy%2BMDRE2v6swuAOCL3%2BkEQ . Is it possible to copy everything to the email?
– Leonardo M. Pires
I did it with conditional formatting and it worked. It has a code to insert the image, but the problem is that you cannot insert as HTML easily, you need to first save as image on the computer and then import as html. If you insert as an image directly, the image hides the introduction and the signature. I will edit later with the insert image code if you want to see how it looks...
– danieltakeshi
Daniel, thank you so much for your help. I was able to solve my problem by adapting some lines of the code.
– Leonardo M. Pires
@Leonardom.Pires Nice! What changes have you made? A way to not insert the letters is instead of using Selection, you can name ranges. Ranges can be set manually or by some algorithm dynamically.
– danieltakeshi
Daniel, I needed to enter some new references and column adjustments. I needed to have the worksheet copied to a specific column, to keep my conditional formatting, since they are referenced by 2 layers of formulas.
– Leonardo M. Pires
Daniel, I have a spreadsheet with several charts, I wanted to put them in the email, but using this your formula, the spreadsheet crashes completely.
– ALLANBZR