How to keep conditional formatting when sending range as body in mail trough VBA.

[zerlotus]

Dear all,

I'm using the following code to send a range as the body of an email.

It works great (credits to the author in the code itself) but it is not copying the color of the cells with conditional formating.

Would someone explain me what should I change in order to also copy the conditional format of the Range("a22: O50") ? The only method I could find was to copy the range and Send Keys Ctrl+V but it is not consistent and fails from time to time.

Thank you in advance,

Sub Mail_Selection_Range_Outlook_Body()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next

    Set rng = Sheets("Cierre de ventas").Range("a22:o50").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    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 Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

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

    On Error Resume Next
    With OutMail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = ""
        .HTMLBody = RangetoHTML(rng)
        .Display
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


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

 

[zerlotus]

Using the solution offered here made it work:

RangetoHTML and Conditional Formatting

Hi, I use the RangetoHTML-Sub from rondebruin.nl to paste the selected range in Outlook. In the selected range, I have two Conditional formattings. 1) If column A contains X, then mark row with red font. 2) If column B contains X, then fill row with yellow background. In Outlook, all rows...

www.mrexcel.com

But all objects are deleted and cant use the macros associated to them.

Thank you.

 

[Logit]

Please post your workbook to a Cloud website for download so it can be examined.

 

[zerlotus]

@Logit,

As I was not able to post the original WS due to sensitive information, I was recreating the issue in another WS, free from real data.

After doing so, I got it to work flawlessly. The issue I was having with the solution I was trying to use in post#2 is, If it has any kind of error, the script stops and delete all images.

So, in order to make it work, be sure to first unprotect sheet, declare correctly the range etc..., otherwise it will delete all images and macros associated to them.

Please, find thereafter the sheet I was recreating for you just in case anyone finds it useful. Working solution is number 2.

http://s000.tinyupload.com/?file_id=67067113464714070631


Thank you again.

Solved

 

[Logit]

Thanks.

My anti-virus really doesn't like that Cloud site. Marked it as Dangerous !