Remove blank lines at the end of Outlook message via Excel VBA

[mcomp72]

I have an Excel workbook that creates an email message in Outlook. The text that goes into the body of the email is first written to a Word document, and the text in the Word document is then copied & pasted into the Outlook message. All of this is working great except for one thing. In the Outlook message, there are two blank lines at the bottom of the message. I have been trying to figure out how to remove them, but I have had no luck.

Here's the code I have for creating the Outlook message. I am sending the Word document as an object to this sub.

Sub EmailFromWordDoc(Doc As Object)

Dim OutApp As Object
Dim OutMsg As Object
Dim editor As Object

[...code that sets some variables...]

Doc.Content.Copy

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

With OutMsg
    Set editor = .GetInspector.WordEditor
    editor.Content.Paste
    .To = EmailAddr
    If BCCStr <> "" Then .BCC = BCCStr
    .Subject = MySubject
    .Attachments.Add PDFName
    .Display
End With

Set OutApp = Nothing
Set OutMsg = Nothing
Set editor = Nothing
 
End Sub

I imagine there must be some code I could put in before the ".Display" line to tell it to remove any blank lines from the bottom of the email. But I have not been able to figure it out, and the online searching I have done so far has not resulted in a solution.

By the way, I don't want the formatting of the email message to change, so I cannot read the body of the message into a string and the rewrite it to the email, because that will change it. The email has very specific formatting that needs to stay as is.

 

[mcomp72]

Here's a screenshot of what the end of the email message looks like.

I would really love for the two blank lines at the end to be gone.