Email excel with color

[JFredGoy]

Hello, this is my first post so I apologize if i make any mistakes
I have the following code that emails the status of a workbook so there is some HTML and VBA coding.
I am very new to coding as well, learning as I need.
When the macro runs it brings back a number in cell B7, though this number can change (formula to another tab).

My issue is when the number is returned, a positive number is highlighted in green and a negative in red, through conditional formatting, i cannot figure out how to have this change in the email, it will simply bring back black, however if i write code in HTML for red it will always be red, and vice-versa for green.

Part of this code is from rondebruin which i changed up fo the HTML portion.

Any suggestion on how i can accomplish this?
I am open to any suggestions in the structure of my coding, i am looking to improve.

 Sub Email_DailyReport_()'Working in Excel 2000-2016
'This example send the last saved version of the Activeworkbook
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim OutApp As Object
    Dim outMail As Object
    Dim MailTo As String
    Dim CopyTo As String
    Dim SubjectEmail As String
    Dim Emailbody As String
    Dim STo As String


    MailTo = Worksheets("Email Dist.").Range("b2:b2") 'modify range of emails to send to:
    CopyTo = Worksheets("Email Dist.").Range("b3:b3") 'modify range of emails to cc:
    SubjectEmail = Worksheets("Email Dist.").Range("b4:b4") 'subject of email
    EmailBody1 = Worksheets("Email Dist.").Range("b5:b5")
    EmailBody2 = Worksheets("Email Dist.").Range("b6:b6")
    EmailBody3 = Worksheets("Email Dist.").Range("b7:b7")
    EmailBody4 = Replace(Worksheets("Email Dist.").Range("b8:b8"), vbCrLf, "<br>")
    EmailBody5 = Worksheets("Email Dist.").Range("b9:b9") 'modify range of emails to send to:
    EmailBody0 = EmailBody2 & EmailBody3 & EmailBody4 & EmailBody5
    
'HTML coding for formatting the body of the email
'**********************************************************************************************************


    SIGN1 = "<p><span style='font-size:11pt'><span style='font-family:Arial,Helvetica,sans-serif'><strong>Jeremy</strong>" 'everything below is the signature portion - for here change the name
    SIGN2 = "<br />"
    SIGN3 = "Financial Analyst / Analyste financier" 'change title
    SIGN4 = "<br />"
    SIGN5 = "<span style='color:#ff0000'><strong>joe </strong></span>| <span style='color:#0000ff'>www.joe.com</span> | Email: <span style='color:#0000ff'>joe@joe.com</span>" 'change email in signature
    SIGN6 = "<br />"
    SIGN7 = "Dir 555.555.5555" 'change extension the phone number
    SIGN8 = "<br />"
    SIGN9 = "Montreal</span></span>" 'change address if need be
    SIGN10 = "</p>"


    SIGN0 = SIGN1 & SIGN2 & SIGN3 & SIGN4 & SIGN5 & SIGN6 & SIGN7 & SIGN8 & SIGN9 & SIGN10
'**********************************************************************************************************


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


    On Error Resume Next
    With outMail
        .To = MailTo
        .CC = CopyTo
        .BCC = ""
        .Subject = SubjectEmail
        .HTMLBody = EmailBody1 & _
                    "Click on this link to open the file : " & _
                    "<A HREF=""file://" & ActiveWorkbook.FullName & _
                    """>Daily Report</A>" & _
                    EmailBody0 & SIGN0
        '.Attachments.Add ActiveWorkbook.FullName 'Remove this if link is inclucded if link not included then remove everything betweem BODY0 and SIGN0 - represents the hyperlink portion
        'You can add other files also like this
        '.Attachments.Add ("C:\test.txt")
        .Display True  'or use .Send - using send prompts an authorization to send emails from excel, better to use display to see the email and send out. much faster as well
        
    End With
    On Error GoTo 0


    Set outMail = Nothing
    Set OutApp = Nothing
    MsgBox "Email Sent"
End Sub
[code\]

I would post the workbook as well but, it seems i do not have permission.

[IMG]https://ibb.co/fkXN75[/IMG]

Much appreciated,
Regards.

 

[Logit]

.

There is a "Function RangetoHTML(rng As Range)" function that can be used along with the HTML macro.
You set the range to be copied in the Function RangetoHTML(rng As Range) see commented note in the function.
(Does that sound as confusing to you as it does to me ? )

Option Explicit


Sub SendEmail()
    Dim rng As Range, OutApp As Object, OutMail As Object
    Dim sCC As String, sSubj As String, sEmAdd As String
     
     '// Change the values of these variables to suit
    sEmAdd = "abc@abc.com"
    sCC = ""
    sSubj = "My Subject"
     
    Set rng = Nothing
    On Error Resume Next
    Set rng = ActiveSheet.Cells(1).CurrentRegion
    On Error GoTo 0
     
    With Application
        .EnableEvents = 0
        .ScreenUpdating = 0
        .Calculation = xlCalculationManual
    End With
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
     
    On Error Resume Next
    With OutMail
        .To = sEmAdd
        .CC = sCC
        .Subject = sSubj
        .HTMLBody = RangetoHTML(rng)
        '.Send '// Change this to .Display if you want to view the email before sending.
        .display
    End With
    On Error GoTo 0
     
    With Application
        .EnableEvents = 1
        .Calculation = xlCalculationAutomatic
    End With
    Set OutMail = Nothing: Set OutApp = Nothing
     
End Sub
 
Function RangetoHTML(rng As Range)
    Dim fso As Object, ts As Object, TempWB As Workbook, TempFile As String
    Dim SendingRng As Range
     
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    Set SendingRng = Worksheets("Sheet1").Range("A1:F14")                          [B]' ' <--- Change range here !!![/B]
    SendingRng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteColumnWidths, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
    End With
    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
    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=")
     
    TempWB.Close 0
    Kill TempFile
     
    Set ts = Nothing: Set fso = Nothing: Set TempWB = Nothing
     
End Function

 

[JFredGoy]

Thank you very much!! however I have run into a slight little detail that makes my OCD run wild!

When it creates the email the coping cells have a double space in between the previous line.
Example:

Hello,

See results:


"macro copies cells here"

What it should be:

Hello,

See results:

"macro copies cells here"

See what i mean?

 

[Logit]

.
Change the "To, From, Subject" etc. portion to this :

On Error Resume Next
    With OutMail
        .To = sEmAdd
        .CC = sCC
        .Subject = sSubj
        .HTMLBody = "Hello, " & "<br><br>" & _
                    "See results :" & "<br>" & _
                    "" & RangetoHTML(rng)
                    
        '.Send '// Change this to .Display if you want to view the email before sending.
        .display

 

[JFredGoy]

I gave that a try however didnt work
I can let my COD slide on this one, do not want to spend more time on this.

 

[Logit]

..........................................................
Having trouble getting the new code to paste here.

 

[Logit]

.
Disregard my last post. The Forum wouldn't let me post the correct code. It kept pasting an old code for some reason. Nothing I did worked.

So, here is a link to the file and code for you to download. Let me know if you have problems with the download or the code. The code has been tested and works.

Amazon Drive

 

[JFredGoy]

Works like a charm! Not sure whats different but, hey I'll take it!

I had trouble posting as well, kept crashing for a couple days - hence the long response.
Now one more question, how do I rate/like/upvote you?

Thanks!

 

[Logit]

.
This new code is looking at Col P to determine what is the last used row. (Previously it was looking at Col B.) That way it includes all of the blue colored rows. Then it
looks at Col B to find all of the blank cells. From that it id's which rows to delete.

I'll send you my Cayman Island bank acct # so you can make a deposit.

Seriously, look at one of my posts in the lower left corner and select one of the zeros adjacent to the symbol you selected? Its new for this Forum, haven't used it yet myself.

​