e-mail sheet in html and attach a spreadsheet

I use Office 365, Windows

I would like to send an e-mail with one sheet as a body html, and another sheet attached to it.

Was able to find online two vba codes by Ron de Buin working on their own, and I was able to merge them together. The only problem I am facing is that the HTML part is coming on black and white, I would love it to come with the conditional formatting, as well as the normal formatting, also, is it possible to include text box and image (logo)?

Sub Mail_Sheet_and_PriceReport()


'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object
    
Dim rng As Range
  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 = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    Set rng = Sheets("Graph").Range("A1:J28").SpecialCells(xlCellTypeVisible)
 
    On Error GoTo 0


    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set Sourcewb = ActiveWorkbook

    'Copy the ActiveSheet to a new workbook
Sheets("Price_report_statistics").Copy
    Set Destwb = ActiveWorkbook

    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007-2016
            Select Case Sourcewb.FileFormat
            Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If .HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56: FileExtStr = ".xls": FileFormatNum = 56
            Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
            End Select
        End If
    End With

    '    'Change all cells in the worksheet to values if you want
    '    With Destwb.Sheets(1).UsedRange
    '        .Cells.Copy
    '        .Cells.PasteSpecial xlPasteValues
    '        .Cells(1).Select
    '    End With
    '    Application.CutCopyMode = False

    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = Format(Now, "yyyy-mm-dd") & " price report"

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

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
             .BodyFormat = 2
            .To = ""
            .CC = ""
            .BCC = ""
            .Subject = "Price Report"
             .HtmlBody = RangetoHTML(rng) & .HtmlBody
            .Attachments.Add Destwb.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            .Display   'or use .Display
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With

    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
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
        '.Cells(1).PasteSpecial xlPasteFormats, , True, True
        .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 you mean the HTML part is ''coming on black and white''? you mean table is being stripped of formatting you did put yourself into it? there is also stuff wrong with your code i think. this

TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

opens file but this

    '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

i dont think matters in terms of what you want to see in the html body of email. and this

    '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=")

is just stream. stream doesnt preserve html code and formats i dont htink. then you put result from that routine in html body with this

             .HtmlBody = RangetoHTML(rng) & .HtmlBody

but you have to know that html table formatting is not the same as table sitting in excel sheet. the < table > element in html has many many css stylings. inline many others. but you can only do inline because html body of email object in outlook can not see external or linked css file. that only for web applications. also, i do not think you need this

             .BodyFormat = 2

if you use .htmlBODY property, body format is changed automatically i think. microsoft knows though. but the enumeration is right yes

https://docs.microsoft.com/en-us/off...k.olbodyformat

Originally Posted by omahaNative_1023

what you mean the HTML part is ''coming on black and white''? you mean table is being stripped of formatting you did put yourself into it? there is also stuff wrong with your code i think. this

Thank you, yes, it comes out as black and white instead of the colors. I don't know a lot of VBA coding, I google what I want to do, find some results, and try to accommodate to my needs.
Which is why there are a lot of things there that today are unnecessary, but honestly I have no idea what most of the stuff means

I also found a version of a VBA code which prints out the table on mail format perfectly, including the colors and color formatting. For instance negative number red, positive green. Do you know if there's a way to include images?

Here's the other VBA code which works with the colors, but I couldn't get this to work along with the other. It copied the range from a different sheet, and by changing Sheet:=ActiveSheet.Name, to Sheets("Graph") would give me a blank e-mail instead.

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("Graph").Range("A1:J28")
 
  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
  
 'StrBody = "This is line 1" & "<br>" & _
 '             "This is line 2" & "<br>" & _
 '             "This is line 3" & "<br><br><br>"
              
  With OutApp.CreateItem(0)
    .BodyFormat = 2
    '.Display  ' reqired for the signature
    .To = "wolthers@gmail.com"  ' "email.is.here"
    .CC = ""
    .BCC = ""
    .Subject = "Wolthers & Associates Price Report"
    .HtmlBody = RangetoHTML(rng) & .HtmlBody 'add "StrBody &" in the begining for the extra lines

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

You will need to use the WordEditor method to copy/paste a range as a picture rather than htmlBody method. e.g.

Sub Main()
  Dim s$, t$, sig$
  'Tools > References > Microsoft Outlook xx.0 Object Library > OK
  Dim olApp As outlook.Application, olMail As outlook.MailItem
  'Tools > References > Microsoft Word xx.0 Object Library > OK
  Dim Word As Document, wr As Word.Range, rTo As Recipient, wos As Word.Selection
  
  'INPUTS to change if needed...........................................................
  s = "Hello World Example" 'Subject
  t = "ken@gmail.com"       'To
  sig = ThisWorkbook.Path & "\sig.rtf" 'contents to copy for signature.
  'End INPUTS...........................................................................
   
  'Get Outlook application
  Set olApp = New outlook.Application
      
  'Make email, send/display.
  'Set olMail = olApp.CreateItem(olMailItem)
  With olApp.CreateItem(olMailItem)
    .Subject = s
    .Importance = olImportanceNormal
    
    'Set the recipient(s) for To field and resolve.
    Set rTo = .Recipients.Add(t)
    rTo.Resolve
    rTo.Type = olTo 'olTo, olcc, olbcc
    If rTo.Resolved = False Then
      Debug.Print t & "email address: Resolved=False"
      '.To = T  'Using rTo above for .To instead.
      GoTo TheEnd
    End If
    
    'Setup WordEditor parts:
    .GetInspector.Display
    Set Word = .GetInspector.WordEditor
    Set wr = Word.Range
       
    'Body, introductory text:
    Word.Content = "Dear VBA Enthusiast, " & vbCrLf & vbCrLf & _
          "I hope that you find this example of copied Excel Range " _
          & "using WordEditor in Outlook " _
          & "useful." & String(4, vbCrLf)
          

    'Body, range A1, copy/paste:
    'Set wos = Word.Windows(1).Selection
    Sheet2.Range("A1:C1").CopyPicture xlScreen, xlBitmap
    wr.Collapse Direction:=wdCollapseEnd
    'Word.Range(Start:=Word.Content.End - 2).PasteAndFormat wdPasteDefault
    wr.Paste
    
    wr.Collapse Direction:=wdCollapseEnd
    Word.Range.InsertAfter String(4, vbCrLf)
    
    'Body, copy/paste contents of sig.rtf, signature...
    GetObject(sig).Range.Copy
    wr.Collapse Direction:=wdCollapseEnd
    'Word.Range(Start:=Word.Content.End - 2).PasteAndFormat wdPasteDefault
    wr.Paste
    
    '.Attachments.Add e 'e is the full path to a file.
    .Display
    '.Send
  End With
  
TheEnd:
  Set olMail = Nothing
  Set olApp = Nothing
End Sub

guess i not understand what you need. well are you saying that the table you want in the email you want colors in it? because if that it, no of course it is not going to do that. like I said, html produce colors based on the html code you write. you have to write markup insside the email! you know html markup? they call it 'inline'