CODEWITHSUNDEEP
vbaexcelemailoutlook
Ben Smith
Ben Smith

Reputation: 819

VBA: Copy and paste cells in a email without losing formatting

I want to be able to send out an email that contains cells from an Excel spreadsheet. Currently I have the following code that inserts the range I want into the email but the problem I am having is that it removes most of the formatting, e.g. the font changes and some of the conditional formatting is removed.

Sub EmailExtract()

Dim objOutlook As Object
Dim objMail As Object
Dim TempFilePath As String
Dim Location As String
Dim Individual As String
Dim rng As Range

Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
Worksheets("Contacts").Activate
Range("A2").Select
While ActiveCell <> ""

    ActiveCell.Offset(1, 0).Select
    Location = ActiveCell.Address
    Individual = ActiveCell.Value
    Worksheets("Individual Output 2").Activate
    Range("C2").Value = Individual

    Set rng = ActiveSheet.Range("A1:M28").Rows.SpecialCells(xlCellTypeVisible)
    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If



    With objMail
            .To = "[email protected]"
            .Subject = ""

            Dim Greeting As String
            If Time >= #12:00:00 PM# Then
                Greeting = "Afternoon ,"
            Else
                Greeting = "Morning,"
            End If



            .HTMLBODY = "<font face=Arial><p>" & "Good " + Greeting + "</p>"
            .HTMLBODY = .HTMLBODY + "<p>" & "Please find below your " & MonthName((Month(Date)) - 1) & " Information." & "</p>"
            .HTMLBODY = .HTMLBODY + RangetoHTML(rng)
            .HTMLBODY = .HTMLBODY + "<p>" & "Kind Regards" & "</p>"
            .HTMLBODY = .HTMLBODY + "<p>" & "Joe Bloggs" & "</p></font>"
            .Display
    End With
    Worksheets("Contacts").Activate
Wend

Set objOutlook = Nothing
Set objMail = Nothing

Set objOutlook = Nothing
Set objMail = Nothing

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:=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

What I want is to be able to email an extract with the formatting applied, is it possible to do this? Maybe by pasting it as a picture into the email?

Upvotes: 1

Views: 8920

Answers (2)

Suraj Kakwani
Suraj Kakwani

Reputation: 1

Replace this line: 

.Cells(1).PasteSpecial Paste:=8

with:

.Cells(1).PasteSpecial Paste:=1

& delete these following 2 lines: 

.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False

Upvotes: 0

ChipsLetten
ChipsLetten

Reputation: 2953

The RangetoHTML function on Ron de Bruin's site has always worked fine for me.

Have you checked the BodyFormat property of the email? It might be defaulting to Rich Text.

Upvotes: 1

Related Questions