How to fit contents of worksheet into a partially opened email

[Nicholas3108]

I am trying to get a selected range from a worksheet (a number of tables) into the body of an email. No issues actually getting the contents of the worksheet into the email. My problem is that the contents of the email need to be fully visible (width-wise at least) when the email is being viewed by recipients in their mailbox (without double clicking on the email to fully open it). Currently the contents can only be viewed fully when the email is opened by double clicking.

How can I make the required range from my worksheet fit into an email so that it is fully visible without double clicking and opening up the message in its own window?

Thanks in advance.

This is the code I'm working with at the moment:

Public Sub Email_File2(EMSubject As String, ToEmailList As Range, CCEmailList As Range, Number As Integer)

Application.ReferenceStyle = xlA1
Dim rgCell As Range
Dim emailbody As Range
Dim StrBody As String
Dim wordDoc As Word.Document

'Copy range of interest
Dim r As Range
Set r = Range("G3:AE" & Number)
'Set r = Range("G2")
r.Copy

For Each rgCell In ToEmailList
If Not IsEmpty(rgCell) Then sEmailList = sEmailList & rgCell.Value & ";"
Next

sEmailList2 = ""
For Each rgCell In CCEmailList
If Not IsEmpty(rgCell) Then sEmailList2 = sEmailList2 & rgCell.Value & ";"
Next

Set olapp = CreateObject("Outlook.Application")
Set outMail = olapp.CreateItem(0)
With outMail
.Subject = EMSubject
.To = sEmailList
.HTMLBody = StrBody
.CC = sEmailList2
End With

'Get its Word editor
outMail.Display
Set wordDoc = outMail.GetInspector.WordEditor

'To paste as picture
'wordDoc.Range.PasteAndFormat wdChartPicture

'To paste as a table
wordDoc.Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False


End Sub

Public Sub Email_File1(EMSubject As String, ToEmailList As Range, CCEmailList As Range, Optional EMailText As Range)

Dim rgCell As Range
Dim emailbody As Range

sEmailList = ""
For Each rgCell In ToEmailList
If Not IsEmpty(rgCell) Then sEmailList = sEmailList & rgCell.Value & ";"
Next

sEmailList2 = ""
For Each rgCell In CCEmailList
If Not IsEmpty(rgCell) Then sEmailList2 = sEmailList2 & rgCell.Value & ";"
Next


'Set emailbody = Range(Range("B4"), Cells(total1, 7))
Set emailbody = Range(Sheets("Price Monitor Report").Range("G3"), Sheets("Price Monitor Report").Range("AR134"))

Set olapp = CreateObject("Outlook.Application")
Set oitem = olapp.CreateItem(0)
With oitem
.Subject = Range("EMSubject")
.To = sEmailList
.HTMLBody = RangetoHTML(emailbody)
'.CC = sEmailList2
.Display
End With

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 past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=2
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteColumnWidths, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
' .Cells(1).PasteSpecial xlPasterowheight, , 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 xublishsource=", _
"align=left xublishsource=")

'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