excel to send as attachment and as image in body of email

[excel01noob]

Hi

Might be quite complicated but can I have a macro preparing to send the data as an attachment to the email but also as a table in the body of the email ?

I have this macro for the attached file

Sub Mail_Sheet()
Dim wPath As String, wFile As String, dam As Object
Dim wMail As String, wSubj As String, wBody As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False

wFile = "Payments report VD " & Format(Date, "dd-mm-yyyy")
wPath = ThisWorkbook.Path & ""

wSender = Sheets("email").Range("A2").Value
wMail = Sheets("email").Range("B2").Value
wCC = Sheets("email").Range("C2").Value
wSubj = Sheets("email").Range("D2").Value
wBody = Sheets("email").Range("E2").Value

Sheets("payment list").Copy

ActiveWorkbook.SaveAs Filename:=wPath & wFile & ".xlsx"
ActiveWorkbook.Close False

Set dam = CreateObject("Outlook.Application").CreateItem(0)
dam.To = wMail
dam.SentOnBehalfOfName = wSender
dam.Subject = wSubj
dam.body = wBody
dam.Attachments.Add wPath & wFile & ".xlsx"
dam.Display '

Set dam = Nothing

End Sub


and I have using this one for the table in the email body

https://www.vba-market.com/excel-vba-insert-excel-table-into-body-of-email-message/

but trying to combine both it's an issue currently

 

[Logit]

.
See if this accomplishes your goal. You will need to edit some of the macro to match your ranges (Mail To, CC, BCC etc.) also the range
of data you want placed in the body of the email.

Option Explicit


Sub SveShts()


Dim xPath As String
Dim xWs  As String


'Establish location of this workbook
xPath = Application.ActiveWorkbook.Path


Application.ScreenUpdating = False
Application.DisplayAlerts = False


'Copy specified sheet to be attached to email. Edit sheet name as required. Sheet is saved as a XLSX workbook
'in same location as this workbook
With Sheets("Sheet1")
    Sheets("Sheet1").Copy
    Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & ActiveSheet.Name & ".xlsx"
    Application.ActiveWorkbook.Close False
End With


Application.DisplayAlerts = True
Application.ScreenUpdating = True


'Call the CopyRows macro (below)
CopyRows
End Sub


'This macro copies the used range (as specified) of the indicated sheet name
Sub CopyRows()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Pivot1")  '<<-- edit sheet name as required
    ws1.Range("A1:N79").Copy
    Mail_Selection_Range_Outlook_Body
End Sub


Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lEndRow
Dim Value As String


Dim xPath As String
Dim xWs  As String


xPath = Application.ActiveWorkbook.Path


Set rng = Nothing
' Only send the used cells in the sheet
Set rng = Sheets("Pivot1").Range("A1:N79")  '<<----- edit range as required


If rng Is Nothing Then
    MsgBox "An unknown error has occurred. "
    Exit Sub
End If


'Turn off screen updating to prevent flickering / flashing
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With


Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)


With OutMail
    .To = "Your email address here in quotes"
    .CC = ""
    .BCC = ""
    .Subject = "Summary Data"


    .HTMLBody = "<p>Text above Excel cells" & "<br><br>" & _
                RangetoHTML(rng) & "<br><br>" & _
                "Text below Excel cells.</p>"
    .Attachments.Add "C:\Users\My\Desktop\Sheet1.xlsx"  '<<--- edit path as required
    
    ' In place of the following statement, you can use ".Send" to
    ' Send the e-mail message.
    .Display
End With


On Error GoTo 0


'Turn on screen updating
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With


'Delete the temporary .xlsx file created for attachment
Kill "C:\Users\My\Desktop\Email Range n Sheet\*.xlsx"


Set OutMail = Nothing
Set OutApp = Nothing


End Sub


''<<<>>> There is no need to edit anything in this Function.


Function RangetoHTML(rng As Range)
    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

Download workbook : https://www.amazon.com/clouddrive/share/V1YxjP6X2x3OA5iybAzXvWpMZv1iXvstKoZXSEeEYTz

 

[DanteAmor]

Here is your updated macro to send the file and range.

The range is the content you have on the "payment list" sheet, but you can change the range in the blue line.

Sub Mail_Selection_Range_Outlook_Body()
  'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
  'Don't forget to copy the function RangetoHTML in the module.
  'Working in Excel 2000-2016
  Dim rng As Range, rws As Long, cols As Long
  Dim wPath As String, wFile As String, dam As Object
  Dim wSender As String, wCC As String, wMail As String, wSubj As String, wBody As String


  Set rng = Nothing
  On Error Resume Next
  'Only the visible cells in the selection
  rws = Sheets("payment list").UsedRange.Rows.Count
  cols = Sheets("payment list").UsedRange.Columns.Count
  Set rng = [COLOR=#0000ff]Sheets("payment list").Range(Sheets("payment list").Cells(1, 1), Sheets("payment list").Cells(rws, cols))[/COLOR]
  'rng.Select
  'You can also use a fixed range if you want
  'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
  On Error GoTo 0
  
  If rng Is Nothing Then
    MsgBox "The selection is not a range or the sheet is protected" & _
    vbNewLine & "please correct and try again.", vbOKOnly
    Exit Sub
  End If
  
  With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .DisplayAlerts = False
  End With
  
  wFile = "Payments report VD " & Format(Date, "dd-mm-yyyy")
  wPath = ThisWorkbook.Path & "\"
  wSender = Sheets("email").Range("A2").Value
  wMail = Sheets("email").Range("B2").Value
  wCC = Sheets("email").Range("C2").Value
  wSubj = Sheets("email").Range("D2").Value
  wBody = Sheets("email").Range("E2").Value
  
  Sheets("payment list").Copy
  ActiveWorkbook.SaveAs Filename:=wPath & wFile & ".xlsx"
  ActiveWorkbook.Close False
  
  On Error Resume Next
  Set dam = CreateObject("Outlook.Application").CreateItem(0)
  dam.To = wMail
  dam.SentOnBehalfOfName = wSender
  dam.Subject = wSubj
  dam.body = wBody
[COLOR=#008000]  dam.Attachments.Add wPath & wFile & ".xlsx"[/COLOR]
[COLOR=#0000ff]  dam.HTMLBody = RangetoHTML(rng)[/COLOR]
  dam.Display '
  Set dam = Nothing
  On Error GoTo 0


  With Application
    .EnableEvents = True
    .ScreenUpdating = True
  End With
End Sub


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

 

[excel01noob]

Hi DanteAmor


I have a tab named "email" where I stored in each cell:

-sender email;
-receipient emails;
-cc if any;
-subject of the email;
-body of the email: just an introductory text which I want to have prior to the pasted table

From your code all worked except the:

-cc emails (none were present) and;
-body of the email: table was there but not the introductory text.

how can i add this ?
apart from this, all is perfect.

 

[excel01noob]

thank you for your time Logit but as I have some emails saved in a tab in the workbook I need to have the code taken them from the excel directly (they might change in the future and it is preferable if people just update the excel cells instead of the code)

 

[Logit]

.
You can still use what you have in the macro I provided :

wSender = Sheets("email").Range("A2").Value
wMail = Sheets("email").Range("B2").Value
wCC = Sheets("email").Range("C2").Value
wSubj = Sheets("email").Range("D2").Value
wBody = Sheets("email").Range("E2").Value

 

[DanteAmor]

From your code all worked except the:
-cc emails (none were present) and;
-body of the email: table was there but not the introductory text.
apart from this, all is perfect.

I fixed the macro with a couple of changes.

Sub Mail_Selection_Range_Outlook_Body()
  'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
  Dim Rng As Range, rws As Long, cols As Long, wPath As String, wFile As String, dam As Object
  Dim wSender As String, wCC As String, wMail As String, wSubj As String, wBody As String
  '
  Set Rng = Nothing
  On Error Resume Next
  rws = Sheets("payment list").UsedRange.Rows.Count
  cols = Sheets("payment list").UsedRange.Columns.Count
  Set Rng = Sheets("payment list").Range(Sheets("payment list").Cells(1, 1), Sheets("payment list").Cells(rws, cols))
  On Error GoTo 0
  '
  If Rng Is Nothing Then
    MsgBox "The selection is not a range or the sheet is protected" & _
    vbNewLine & "please correct and try again.", vbOKOnly
    Exit Sub
  End If
  '
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  '
  wFile = "Payments report VD " & Format(Date, "dd-mm-yyyy")
  wPath = ThisWorkbook.Path & "\"
  wMail = Sheets("email").Range("B2").Value
  wSender = Sheets("email").Range("A2").Value
  wCC = Sheets("email").Range("C2").Value
  wSubj = Sheets("email").Range("D2").Value
  wBody = Sheets("email").Range("E2").Value
  Sheets("payment list").Copy
  ActiveWorkbook.SaveAs Filename:=wPath & wFile & ".xlsx"
  ActiveWorkbook.Close False
  '
  On Error Resume Next
  Set dam = CreateObject("Outlook.Application").CreateItem(0)
  dam.To = wMail
  dam.SentOnBehalfOfName = wSender
[COLOR=#ff0000]  dam.Cc = wCC[/COLOR]
  dam.Subject = wSubj
  dam.Attachments.Add wPath & wFile & ".xlsx"
[COLOR=#ff0000]  dam.HTMLBody = wBody & RangetoHTML(Rng)[/COLOR]
  dam.Display '
  Set dam = Nothing
  On Error GoTo 0
  '
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub
'
Function RangetoHTML(Rng As Range)
  ' Changed by Ron de Bruin 28-Oct-2006' Working in Office 2000-2016
  Dim fso As Object, ts As Object, TempFile As String, 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

 

[Logit]

.
excel01Noob:

Just so there won't be any confusion ... this is the exact replacement :

With OutMail    .Sender = Sheets("email").Range("A2").Value
    .To = Sheets("email").Range("B2").Value
    .CC = Sheets("email").Range("C2").Value
    .BCC = ""
    .Subject = Sheets("email").Range("D2").Value
    .HTMLBody = Sheets("email").Range("D2").Value & _
                RangetoHTML(rng) & "" & _
                "additional text below Excel cells."

 

[excel01noob]

I don't want to save any copy of the attached excel.
I removed this line code but by doing that the email is no longer being created

ActiveWorkbook.SaveAs Filename:=wPath & wFile & ".xlsx"


How can I fine tune this to not save the copy ?

Otherwise, macro works very well !

 

[DanteAmor]

I don't want to save any copy of the attached excel.
I removed this line code but by doing that the email is no longer being created
ActiveWorkbook.SaveAs Filename:=wPath & wFile & ".xlsx"
How can I fine tune this to not save the copy ?
Otherwise, macro works very well !

You don't want to save the file, but you want to send a copy of the file?

If you don't want to send the file and just want to send the range, then also delete this lines:

  wFile = "Payments report VD " & Format(Date, "dd-mm-yyyy")
  wPath = ThisWorkbook.Path & "\"


  Sheets("payment list").Copy
  ActiveWorkbook.SaveAs Filename:=wPath & wFile & ".xlsx"
  ActiveWorkbook.Close False

  dam.Attachments.Add wPath & wFile & ".xlsx"