Copying from Excel to Outlook - what am I doing wrong?

[davidfrommke]

Hello All -



I am attempting to come up with a macro that will allow me to click a button and move data from the excel spreadsheet and insert into an email.



The problem I have is that when I copy the information from Excel, it formats into the email differently. I would like to keep the same format / picture.



I have copied and pasted the VBA code I am using below.



I also have attachments showing what it looks like in Excel and what I actually get when I get it into Outlook.



Thank you for your help.



Dave



Sub Send_Email()



'Updated by Extendoffice 20200119

Dim xRg As Range

Dim I, J As Long

Dim xAddress As String

Dim xEmailBody As String

Dim xMailOut As Outlook.MailItem

Dim xOutApp As Outlook.Application

On Error Resume Next

xAddress = ActiveWindow.RangeSelection.Address

Set xRg = Application.InputBox("Please select range you need to paste into email body", "KuTools For Excel", xAddress, , , , , 8)

If xRg Is Nothing Then Exit Sub

Application.ScreenUpdating = False

Set xOutApp = CreateObject("Outlook.Application")

Set xMailOut = xOutApp.CreateItem(olMailItem)

For I = 1 To xRg.Rows.Count

For J = 1 To xRg.Columns.Count

xEmailBody = xEmailBody & " " & xRg.Cells(I, J).Value

Next

xEmailBody = xEmailBody & vbNewLine

Next

xEmailBody = "Hi" & vbLf & vbLf & " revised work schedule for following week" & vbLf & vbLf & xEmailBody & vbNewLine

With xMailOut

.Subject = "Revised work schedule for following week"

.To = johnsmith@smith.com

.Body = xEmailBody

.Display

'.Send

End With

Set xMailOut = Nothing

Set xOutApp = Nothing

Application.ScreenUpdating = True



End Sub

 

[John_w]

There are 2 ways of putting the range of cells in an email body with the formatting and layout preserved:

1. Call Ron de Bruin's RangeToHTML function to generate a HTML string containing the formatted cells.

2. Save the cells as a temporary image file and incorporate it in a HTML string with suitable tags.

Either way, the code must assign the HTML string to the Outlook email's HTMLbody property instead of Body. You can add extra text above and below the cells in the email, with appropriate HTML tags.

This macro shows the first method.

Public Sub Send_Email()

    Dim emailRange As Range
    Dim OutApp As Outlook.Application
    Dim OutEmail As Outlook.MailItem
    Dim HTML As String
    
    Set emailRange = Application.InputBox("Please select the range to paste into the email body.", "Email Work Schedule", _
                                          ActiveWindow.RangeSelection.Address, , , , , 8)
    If emailRange Is Nothing Then Exit Sub
    
    HTML = "<p>Hi,</p><p>Revised work schedule for following week.</p>" & _
           RangeToHTML(emailRange) & _
           "<p>Regards,<br>Name</p>"
     
    Application.ScreenUpdating = False
        
    Set OutApp = New Outlook.Application  'CreateObject("Outlook.Application")
    Set OutEmail = OutApp.CreateItem(olMailItem)
    
    With OutEmail
        .Subject = "Revised work schedule for following week"
        .To = "johnsmith@smith.com"
        .HTMLbody = HTML
        .Display
        '.Send
    End With
    
    Application.ScreenUpdating = True
    
    Set OutEmail = Nothing
    Set OutApp = Nothing

End Sub


'https://www.rondebruin.nl/win/s1/outlook/bmail2.htm
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 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=")

    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