Conditional Formatting from several sheets using Ron de Bruin

[cactus_ritter]

I am using the Sub Mail_Selection_Range_Outlook_Body() from Ron de Bruin to set up a macro to send an email taking the information from several sheets with reports that I have to send and it works pretty well, but the code doesn't allow conditional formatting to be pasted into outlook.

The behaviour is basically setting up a button to send an email for each of the sheets, so I have the Sub to be called multiple times from another Sub changing the differences from each sheet (like email, department...). This data is sent as arguments to the de Bruin's Sub.

Everything works perfectly as intended, but the conditional formatting is lost. I have tried many things but I can't not make it work for me to keep the conditional formatting.

Sub Mail_Selection_Range_Outlook_Body(Department As String, DepLeaderName As String, DepLeaderEmail As String)
'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
    Dim sh1 As Worksheet

    Dim MsgText1 As String
    Dim MsgText2 As String
    Dim SenderName As String
    Dim InputDate As Date
    Dim CWNumber As Long
    Dim CurrentYear As Long

    MsgIntro = "Dear " & DepLeaderName & "<br/><br/> "

    MsgText1 = "Please find the report below. <br/><br/> "

    MsgText2 = "The report uses raw data from today. <br/><br/> Kind regards,<br/> "

    SenderName = "Report Team <br/><br/>"

    InputDate = Now
    CWNumber = Application.WorksheetFunction.WeekNum(InputDate)
    CurrentYear = Year(Now)

    Set rng = Nothing
    On Error Resume Next

    Set sh1 = Worksheets(Department)

    'You can also use a fixed range if you want
    LastRow = sh1.Cells(sh1.Rows.Count, "H").End(xlUp).Row
    Set rng = sh1.Range("B7:H" & LastRow).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 = DepLeaderEmail
        .CC = "" 
        .BCC = ""
        .Subject = "Report for " & Department & " CW" & CWNumber & " " & Year(Now)
        .HTMLBody = "<font style=""font-family: Calibri; font-size: 12pt;""/font>" & MsgIntro & MsgText1 & MsgText2 & SenderName & RangetoHTML(rng)
        .Send   'or use .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

 

[cactus_ritter]

Well I tried another code by user ZVI. This is the link.

This is the code that I am using. It still loses the conditional formatting that I have. I don't really know what else to change.

Sub Mail_Selection_Range_Outlook_Body(Department As String, DepLeaderName As String, DepLeaderEmail As String)
  '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
  '(ZVI-2018-01-05: modified a bit)
  Dim rng As Range
  Dim OutApp As Object
  Dim IsCreated As Boolean
  Dim sh1 As Worksheet
  Dim wb As Workbook
    
  Dim MsgText1 As String
  Dim MsgText2 As String
  Dim SenderName As String
  Dim InputDate As Date
  Dim CWNumber As Long
  Dim CurrentYear As Long
  
  MsgIntro = "Dear " & DepLeaderName & "<br/><br/> "

  MsgText1 = "Please find the report on the report below. <br/> "

  MsgText2 = "<br/>The report uses raw data from today. <br/><br/> Kind regards,<br/> "

  SenderName = "Report Team "

  InputDate = Now
  CWNumber = Application.WorksheetFunction.WeekNum(InputDate)
  CurrentYear = Year(Now)
  
  Set sh1 = Worksheets(Department)
 
  'Only the visible cells in the selection will be sent
  'Set rng = Selection
  'You can also use a fixed range if you want
  LastRow = sh1.Cells(sh1.Rows.Count, "H").End(xlUp).Row
  Set rng = sh1.Range("B7:H" & LastRow).SpecialCells(xlCellTypeVisible)
 
  If TypeName(rng) <> "Range" Then
    MsgBox "The selection is not a range" & vbLf & "please correct and try again."
    Exit Sub
  End If
 
  On Error Resume Next
  Set OutApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  Err.Clear
 
  With OutApp.CreateItem(0)
    .BodyFormat = 2
    '.Display  ' reqired for the signature
    .To = DepLeaderEmail
    .CC = ""
    .BCC = ""
    .Subject = "Report for " & Department & " CW" & CWNumber & " " & Year(Now)
    .HTMLBody = "<font style=""font-family: Calibri; font-size: 12pt;""/font>" & MsgIntro & MsgText1 & RangetoHTML(rng, Department) & MsgText2 & SenderName & .HTMLBody 'RangetoHTML(rng) & .HTMLBody
    .Send
  End With
 
  ' Catch errors
  If Err Then
    Application.Visible = True
    MsgBox "E-mail has not been sent" & vbLf & Err.Description, vbExclamation, "Error"
  End If
 
  ' Try to quit Outlook if it was created via this code
  If IsCreated Then OutApp.Quit
 
  ' Release the memory of the object variable
  Set OutApp = Nothing
 
End Sub
 
 
Function RangetoHTML(rng As Range, Department As String)
  ' Code of Ron de Bruin - https://www.rondebruin.nl/win/s1/outlook/bmail2.htm
  ' Working in Excel 2000-2016
  ' (ZVI-2018-01-05: modified for CF supporting)
  
  Dim TempFile As String, ddo As Long
  TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
  
  Workbooks("Report.xlsm").Activate
  
  Worksheets(Department).Activate
 
  ' Temporary publish the rng range to a htm file
  ddo = ActiveWorkbook.DisplayDrawingObjects
  ActiveWorkbook.DisplayDrawingObjects = xlHide
  With ActiveWorkbook.PublishObjects.Add( _
       SourceType:=xlSourceRange, _
       Filename:=TempFile, _
       Sheet:=ActiveSheet.Name, _
       Source:=Union(rng, rng).Address, _
       HtmlType:=xlHtmlStatic)
    .Publish True
    .Delete
  End With
  ActiveWorkbook.DisplayDrawingObjects = ddo
 
  'Read all data from the htm file into RangetoHTML
  With CreateObject("Scripting.FileSystemObject").GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = Replace(.ReadAll, "align=center x:publishsource=", "align=left x:publishsource=")
    .Close
  End With
 
  'Delete the htm file we used in this function
  Kill TempFile
 
End Function