Remove unnecessary lines from cells when using Ron de Bruin's 'Range to HTML'

Question

I've modified Ron de Bruin's code for Mail Range/Selection in the body of the mail (Excel Range to HTML Outlook) to my needs. Ron's code can be found here: https://www.rondebruin.nl/win/s1/outlook/bmail2.htm

Refer to this image:

The range in the worksheet is developed from inputs provided by a user in a UserForm. The 'Comments' column has comments entered by the user that may span several lines. For example, D8 has the comments entered by a user in a TextBox in the UserForm. To enter comments on a new line, the user used Shift+Enter in the TextBox.

Now, everything looks good in Excel (D8). But after using Ron's procedure to convert this range to HTML and display in Outlook's Email body, an additional line is added between each comment.

How do I stop this from occurring or remove these unnecessary additional lines?

Note: I have not heavily modified Ron's code. I have used it as is, except for minor tweaks and selecting range from A1 to DN where N is the last row of data (in this case, 8).

Code

Sub SendReport(shtname As String, nrows As Long, name As String)

Dim sht As Worksheet, wsdata As Worksheet
Dim sendrng As Range, rngdata As Range

'Set data sheet
Set wsdata = ThisWorkbook.Worksheets("Data")
Set rngdata = wsdata.Range("A2").CurrentRegion
Set sht = ThisWorkbook.Sheets(shtname)

'Select range to send
Set sendrng = Nothing
On Error Resume Next
Set sendrng = sht.Range("A1:D" & 6 + nrows)
On Error GoTo 0
If sendrng Is Nothing Then
    msg = MsgBox("Invalid selection or protected sheet!" & vbCrLf & _ 
    "Please correct and try again.", vbOKOnly + vbCritical, "Email Report")
    Exit Sub
End If

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

'Email To and CC details
emailcc = ""
factory = Application.WorksheetFunction.VLookup(name, rngdata, 2, False)
If factory = "Gas" Then
    emailto = wsdata.Range("K7").Value
ElseIf factory = "Electricity" Then
    emailto = wsdata.Range("K8").Value
End If

'Email, RangetoHTML
On Error Resume Next
With OutMail
    .To = emailto
    .CC = emailcc
    .BCC = ""
    .Subject = "Report: " & sht.Range("4").Value & ", " & 
sht.Range("B4").Value
    .HTMLBody = RangetoHTML(sendrng)
    .Display
    '.Send
End With
On Error GoTo 0

Application.EnableEvents = True
Application.ScreenUpdating = True
Set OutMail = Nothing
Set OutApp = Nothing

'Confirm send to user
msg = MsgBox("Report sent through Outlook. Check 'Sent Items'.", _ 
vbOKOnly + vbInformation, "Email Report")

End Sub

'---------------------------------------------------------------------
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 paste 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

Edit: 01 May 2020

I noticed that the issue occurs only in cells where the line almost reaches the entire width of the cell. I used the Range.AutoFit for the all columns then set widths for B, C, and D. This is the code I'm using for formatting:

'Final formatting
sht.Range("A1:D" & 6 + nrows).Font.Size = 10
sht.Range("A1:D" & 6 + nrows).Font.Name = "Arial"
sht.Columns("A:D").AutoFit
sht.Columns("B").ColumnWidth = 18
sht.Columns("C").ColumnWidth = 18
sht.Columns("D").ColumnWidth = 80
sht.Range("D7:D" & 6 + nrows).WrapText = True
sht.Range("A1").Select

Could this be causing the issue?

Edit: 05 May 2020

Per @teylyn's suggestion, I copied the table and turned on invisible characters in Word. At the end of each line, there seems to be an additional carriage return character. How do I remove these?

Looks to me that the extra space between the comment lines in the email may be caused by a paragraph style that uses spacing before and/or after the paragraph. Have you checked that out? — teylyn, Apr 30 '20 at 00:13
@teylyn, I checked the Paragraph Style in Excel and Outlook. I don't think that's the issue. If it is, how would I control it from my code? — Adarsh Jeyes, May 01 '20 at 20:54
So, there's a character in that empty line in the email? If you copy the table from the email to Word and turn on invisible characters, like paragraph marks, what does that look like? — teylyn, May 03 '20 at 20:47
The line break when the width of the cell is reached is a known thing in Excel. The invisible line feed character takes up space and causes the line to wrap. The extra line in your email is not the same cause, obviously. As I said, inspect it in Word to learn the cause of it. — teylyn, May 03 '20 at 20:50
@teylyn Yes, there are additional carriage-return characters at the end. Not sure why. How can I remove these, either in Excel or in the email body? — Adarsh Jeyes, May 05 '20 at 13:51

Remove unnecessary lines from cells when using Ron de Bruin's 'Range to HTML'

0 Answers0