RangetoHTML and Conditional Formatting

[orjanmen]

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 (except first row) are marked With red font (also thoose without A="X". None of the rows are filled With yellow (not even thoose With B="X". Everything looks good in Excel, but not in Outlook.

Anyone With a solution for this?

 

[ZVI]

Hi, try this modification of the Ron's code:

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
  '(ZVI-2018-01-05: modified a bit)
  Dim rng As Range
  Dim OutApp As Object
  Dim IsCreated As Boolean
 
  'Only the visible cells in the selection will be send
  Set rng = Selection
  'You can also use a fixed range if you want
  'Set rng = Sheets("YourSheet").Range("D4:D12")
 
  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 = ""  ' "email.is.here"
    .CC = ""
    .BCC = ""
    .Subject = "This is the Subject line"
    .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)
  ' 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"
 
  ' 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

 

[orjanmen]

Thanks, Vladimir. This works great.

Now another issue: The cells seem to have a fixed width. On small screens (mobile phones) the text inColumn A are overlapping B, B overlaps C and so on.

Any fix for this?