Export an excel range into Outlook

[Gtasios4]

Hello all,

I want to create in the below quotation tool a command button where it would export by coping an excel range after after the user has filled it out.

The range in that "table" is A1:O6, however the user might insert a row above the "TOTAL" bar. Thus the code should somehow copy the table in that case as well.

I would really appreciate if you could help me into doing that.

Thanks in advance.

 

[portews]

Here's some code I use to create an email in Outlook, copy a range from the activeworkbook to make an HTML file of it and paste that into the body of the email. It also makes an exact copy of the activeworkbook to a temp file and attaches it to the email.

Sub OutlookSendMail()
'https://www.mrexcel.com/board/threads/export-an-excel-range-into-outlook.1208614/

    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
ActiveWorkbook.SaveCopyAs Filename:=Environ("temp") & "\" & ThisWorkbook.Name
 With OutMail
        .Display 'This will display the message for you to check and send yourself
         'Specify the email subject
        .Subject = "add subject here"
         'Specify who it should be sent to. Repeat this line to add further recipients.  You can use cell references or variables here, too.
        .Recipients.Add "Add your 1st Recipient@x.com"
        .Recipients.Add "Add your 2nd Recipient@x.com" 'add more lines as necessary
'        .Recipients.Type = olBCC
         'specify the text to appear in the email
        .HTMLBody = RangetoHTML(ThisWorkbook.Sheets(1).Range("A1:O6")) & .HTMLBody
         'specify the file to attach
        .Attachments.Add Environ("temp") & "\" & ThisWorkbook.Name
'        .Paste
         'Choose which of the following 2 lines to have commented out
        '.Display
         '.Send ' This will send the message straight away
    End With
    Kill Environ("temp") & "\" & ThisWorkbook.Name
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
    Set TempWB = Workbooks.Add(1)
    
    Rng.Copy
    On Error Resume Next
    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
        'insert rows to put text before the table.  This may format weird because you are adding to table.
        .Rows("1:4").Insert Shift:=xlDown
        .Cells(1, 1) = "Stuff to put in before you paste in the copy range"
        .Cells(1, 1).Font.Bold
        .Cells(2, 1) = "More lines before the table"
        .Cells(3, 1) = "One more line before the table"

        .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

 

[Gtasios4]

Here's some code I use to create an email in Outlook, copy a range from the activeworkbook to make an HTML file of it and paste that into the body of the email. It also makes an exact copy of the activeworkbook to a temp file and attaches it to the email.

Sub OutlookSendMail()
'https://www.mrexcel.com/board/threads/export-an-excel-range-into-outlook.1208614/

    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
ActiveWorkbook.SaveCopyAs Filename:=Environ("temp") & "\" & ThisWorkbook.Name
 With OutMail
        .Display 'This will display the message for you to check and send yourself
         'Specify the email subject
        .Subject = "add subject here"
         'Specify who it should be sent to. Repeat this line to add further recipients.  You can use cell references or variables here, too.
        .Recipients.Add "Add your 1st Recipient@x.com"
        .Recipients.Add "Add your 2nd Recipient@x.com" 'add more lines as necessary
'        .Recipients.Type = olBCC
         'specify the text to appear in the email
        .HTMLBody = RangetoHTML(ThisWorkbook.Sheets(1).Range("A1:O6")) & .HTMLBody
         'specify the file to attach
        .Attachments.Add Environ("temp") & "\" & ThisWorkbook.Name
'        .Paste
         'Choose which of the following 2 lines to have commented out
        '.Display
         '.Send ' This will send the message straight away
    End With
    Kill Environ("temp") & "\" & ThisWorkbook.Name
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
    Set TempWB = Workbooks.Add(1)
   
    Rng.Copy
    On Error Resume Next
    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
        'insert rows to put text before the table.  This may format weird because you are adding to table.
        .Rows("1:4").Insert Shift:=xlDown
        .Cells(1, 1) = "Stuff to put in before you paste in the copy range"
        .Cells(1, 1).Font.Bold
        .Cells(2, 1) = "More lines before the table"
        .Cells(3, 1) = "One more line before the table"

        .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

Hi Portews,

Thank you so much for your valuable code!! I really appreciate your help. It works fine however I am facing the below errors:

1. As you can see in the picture the last line's format is removed in the body mail
2. Is it possible to copy just that table in a current body email, thus not attaching the entire workbook, adding recepients and subject.
3. Lastly I've noticed that when I am adding a row/s above the "total bar" by clicking my below code, your code removes the "total bar"and some ranges in the body mail.

Sub INSERTCOPY()
 resp = MsgBox("                   Are you sure?", vbYesNo, "")
    If resp = vbNo Then Exit Sub
   lastrow = Cells(Rows.Count, "N").End(xlUp).Row
    inarr = Range(Cells(1, 14), Cells(lastrow, 14))
    For i = 5 To lastrow
     If inarr(i, 1) = "total:" Then
      Exit For
     End If
    Next i
rowno = ActiveCell.Row
If rowno < i And rowno > 4 Then
With ActiveCell.EntireRow
.Copy
.Offset(1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
On Error Resume Next
.Offset(1).SpecialCells(xlCellTypeConstants).Value = ""
Application.CutCopyMode = False
On Error GoTo 0
End With
Else
MsgBox "Please select a cell above the total bar"
End If
End Sub

 

[portews]

1. As you can see in the picture the last line's format is removed in the body mail. Try re-doing the borders around the total cells to make sure they are not top borders to the row below. Otherwise you may have to include the row below, just for formatting. See comment 3 for instructions.
2. Is it possible to copy just that table in a current body email, thus not attaching the entire workbook, adding recepients and subject. To not add a copy of the workbook, comment out or delete this line in the SUB

   .Attachments.Add Environ("temp") & "\" & ThisWorkbook.Name

   . To add recipients and subject, look for the "..Subject" and ".Recipients.Add" in the SUB. You can either hard code them by changing the text inside the quotes or refer them to a cell, e.g.

   .Subject = Range("A4")

3. Lastly I've noticed that when I am adding a row/s above the "total bar" by clicking my below code, your code removes the "total bar"and some ranges in the body mail. You'll need to adjust what range you want to print with the line:

   .HTMLBody = RangetoHTML(ThisWorkbook.Sheets(1).Range("A1:O6")) & .HTMLBody

   I set it to what I saw in the example.

I'm glad the code is helping you. All I ask is that you pay it forward.