Line space in e-mail body

[ThrottleWorks]

Hi,

I am trying to create an e-mail with below code.

My e-mail body has few text lines, one table and a chart.

I am able to paste chart in e-mail body. However my problem is there is no line space between last table of e-mail body and chart.

For example, my current e-mail looks like below.

--------------------------------------------------------------------

Hi,

Dummy text.
Dummy text. Dummy text.
Dummy text. Dummy text. Dummy text.
Dummy text. Dummy text. Dummy text. Dummy text.

Table
Chart

I want it as below.


Hi,

Dummy text.
Dummy text. Dummy text.
Dummy text. Dummy text. Dummy text.
Dummy text. Dummy text. Dummy text. Dummy text.

Table
line space 1
line space 2
Chart

‘--------------------------------------------------------

Can anyone please help me in this.

Option Explicit

Sub Create_Email()
    Dim EmailRng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim TempLr As Long
  
    TempLr = ChartRngSht.Cells(ChartRngSht.Rows.Count, 1).End(xlUp).Row + 1
    ChartRngSht.Cells(TempLr, 1) = Application.WorksheetFunction.WorkDay(Date, -2)
    ChartRngSht.Cells(TempLr, 1).NumberFormat = "dd.mm.yyyy"
    ChartRngSht.Cells(TempLr, 2) = MyCount_1
    ChartRngSht.Cells(TempLr, 3) = MyCount_2
    ChartRngSht.Cells(TempLr, 4) = ChartRngSht.Cells(TempLr - 1, 4)
    ChartRngSht.Cells(TempLr, 5) = 4
    ChartRngSht.Cells(TempLr, 6) = 4
    ChartRngSht.Cells(TempLr, 7) = 6
  
    Dim TempLr_1 As Long
    TempLr = ChartRngSht.Cells(ChartRngSht.Rows.Count, 1).End(xlUp).Row
    TempLr_1 = TempLr - 29
  
    ChartRngSht.Range(ChartRngSht.Cells(TempLr_1, 1), ChartRngSht.Cells(TempLr, 7)).Copy
    ChartRngSht.Range("AA4").PasteSpecial xlPasteAll
    ChartBook.Save
  
    MacroBook.Activate
    EmaiSht.Select
  
    EmaiSht.Range("F20:Q65000").Clear
    TempLr = MapSht.Cells(MapSht.Rows.Count, 55).End(xlUp).Row
    If TempLr <> 1 Then
        MapSht.Range("BC2:BC" & TempLr).Copy
        TempLr = EmaiSht.Cells(EmaiSht.Rows.Count, 6).End(xlUp).Row + 1
        EmaiSht.Cells(TempLr, 6).PasteSpecial xlPasteAll
    End If
  
    TempLr = MapSht.Cells(MapSht.Rows.Count, 27).End(xlUp).Row
    If TempLr <> 1 Then
        MapSht.Range("AA1:AL" & TempLr).Copy
        TempLr = EmaiSht.Cells(EmaiSht.Rows.Count, 6).End(xlUp).Row + 2
        EmaiSht.Cells(TempLr, 6).PasteSpecial xlPasteAll
    End If
  
    TempLr = EmaiSht.Cells(EmaiSht.Rows.Count, 6).End(xlUp).Row
    Set EmailRng = EmaiSht.Range("F1:Q" & TempLr)
    TempLr = EmaiSht.Cells(EmaiSht.Rows.Count, 6).End(xlUp).Row + 2
  
    EmaiSht.Range("A1").Select
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    Dim MyPath As String
    MyPath = ThisWorkbook.Worksheets("Mapping").Range("E8").Value
  
    Dim ChartPath As String
    ChartPath = ThisWorkbook.Worksheets("Mapping").Range("E8").Value
  
    Dim ChtObj As ChartObject
    Dim MyChartName As String
  
    For Each ChtObj In ChartSht.ChartObjects
        MyChartName = ChtObj.Name
    Next ChtObj
  
    Dim MyChartAddress As String
    Dim MyChartPath As Variant
    MyChartPath = (ChartPath & "Chart1.png")
  
    Dim Signature As String
    Dim olsave As Variant
    With OutMail
        .display
        Signature = OutMail.HTMLBody
      
        .To = EmailMapSht.Range("B1").Value
        .CC = EmailMapSht.Range("B2").Value
        .Subject = EmailMapSht.Range("B3").Value
        .Attachments.Add (MapSht.Range("E10").Value)
        .Attachments.Add (MapSht.Range("E12").Value)
        ChartSht.ChartObjects("Chart 1").Chart.Export ChartPath & "\Chart1.png"
        .Attachments.Add MyChartPath
      
      
        .HTMLBody = RangetoHTML(EmailRng) & " " & "<img src='Chart1.png'" & "width='1200' height='800'" & Signature
        .display
    End With
  
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
  
    Dim MacroBook As Workbook
    Dim EmailSht As Worksheet
  
    Dim OutApp As Object
  
  
    Set MacroBook = ThisWorkbook
    Set EmailSht = MacroBook.Worksheets("EmailSht")
  
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
  
    Dim TempLr As Long
    Dim EmailRng As Range
  
    TempLr = EmailSht.Cells(EmailSht.Rows.Count, 6).End(xlUp).Row + 2
    Set EmailRng = EmailSht.Range("F1:Q" & TempLr)
  
    EmailRng.Copy
    Set TempWB = Workbooks.Add(1)
    TempWB.Worksheets("Sheet1").Range("A1").PasteSpecial xlPasteValues
    TempWB.Worksheets("Sheet1").Range("A1").PasteSpecial xlPasteFormats
  
    TempLr = Cells(Rows.Count, 1).End(xlUp).Row + 2
  
    Dim TempSht As Worksheet
    Set TempSht = TempWB.Worksheets("Sheet1")
  
    Cells.Font.Name = "Calibri"
    Cells.Font.Size = 10
  
    With TempWB.Sheets(1)
        On Error Resume Next
            .DrawingObjects.Visible = True
            .DrawingObjects.Delete
        On Error GoTo 0
    End With
  
    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

    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=")
    RangetoHTML = Replace(RangetoHTML, "<!--[if !excel]>&nbsp;&nbsp;<![endif]-->", "")
    TempWB.Close savechanges:=False
  
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

 

[Chihiro]

After the table, try adding <BR> twice.

 

[ThrottleWorks]

Hi @Chihiro sir, thanks a lot for the help. Sorry for late reply. It is working great.
Have a nice day ahead.