Create email from Excel-VBA to include Range with Conditional Formatting

问题

Background:

I have dug around and learned to create an email per Rob de Bruin's guide, herein "RDB". In trying to get the contents of my email appropriate, I have found that the RangetoHTM function RDB created does not maintain colors applied via conditional formatting.

I have attempted a suggested workaround altering the existing code to include .Cells(1).PasteSpecial xlPasteAllUsingSourceTheme (suggested here), though that also does not appear to resolve the issue.

I have attempted to move onto using SendKeys, where I cannot get "^V" to work, hoping that there is another way to do this. I have attempted to step through and manually Ctrl+V and there is no pastable content, despite the spreadsheet having the selected range outlined.

Issue:

When copying a range from Excel, which has basic coloring as well as additional coloring from conditional formatting, I am unable to paste the desired range into an Outlook email via code as the conditional formatting colors are removed.

Making an image (png) of the range is not an acceptable output as there are links that need to be followed in one column of the range to be pasted.

Question:

Additional suggestions would be appreciated, though that would make this a subjective, discussion piece which is Too Broad for StackOverflow... so I'll try to keep this specific to the code I have created/modified.

If anyone is aware how to modify RDB's code to allow conditionally formatted cells, that would also be awesome.

Given I am attempting SendKeys, does anyone know why I cannot get the paste to work?

Code in question:

Note: I had to bastardize module names and remove some content (standard), so pardon the not so specific labels on the private subs being called. There are five (5) subroutines and one (1) function in the below code, in this order:

Public Sub execute() 'the one that calls the private subs in the preferred order
Private Sub SheetVals() 'sets the ranges in the excel sheet and values variables
Private Sub MsgContent() ' Creates the email and uses the sheet vals
Private Sub SetToNothing() 'set blah = nothing
Private Function CopyRangeToHTML(ByVal name As Range) 'RDB's code
Private Sub send_keys_test() ' how i've been attempting to do sendkeys

Option Explicit
Private i As Long, legendrng As Range, tablerng As Range, mval As String, sdate As String, bmonth As String, bdate As String
Private msg As Outlook.MailItem, oapp As Outlook.Application

Public Sub execute()
    If ActiveSheet.name <> "NAME" Then Exit Sub
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlManual
    End With
    '''
    SheetVals
    MsgContent
    send_keys_test 'Very bottom of the code
    SetToNothing
    '''
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .Calculation = xlAutomatic
    End With
End Sub

Private Sub SheetVals()
    Dim lrtable As Long, lrlegend As Long, lc As Long
    With Sheets("Name")
        lc = 9
        lrlegend = .Cells(.Rows.Count, 1).End(xlUp).Row
        lrtable = .Cells(.Rows.Count, lc).End(xlUp).Row
        Set legendrng = .Range(.Cells(lrlegend - 4, 1), .Cells(lrlegend, 1))
        Set tablerng = .Range(.Cells(3, 1), .Cells(lrtable, lc))
        mval = Format(.Cells(.Columns(1).Find(What:="Shalom", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Row + 3, 6).Value, "$#,###")
        sdate = Format(Date, "yyyyMMMdd")
        bmonth = Format(Date, "MMM")
        bdate = Format(Date, "MMM dd, yyyy")
    End With
End Sub

Private Sub MsgContent()
    Set oapp = CreateObject("Outlook.Application")
    Set msg = oapp.CreateItem(olMailItem)
    With msg
        .Display
        .Importance = 2
        .to = "" 
        .Subject = "Subject " & sdate
        .HTMLBody = _
            "<HTML><body>Content.<br></body></HTML>"
        '.HTMLBody = .Body & CopyRangeToHTML(tablerng)
        .Attachments.Add ActiveWorkbook.FullName
    End With
End Sub

Private Sub SetToNothing()
    Set msg = Nothing
    Set oapp = Nothing
    i = 0
    Set legendrng = Nothing
    Set tablerng = Nothing
    mval = ""
    sdate = ""
    bmonth = ""
    bdate = ""
End Sub

Private Function CopyRangeToHTML(ByVal name As Range)
    ' Changed by Ron de Bruin 28-Oct-2006
    ' Working in Office 2000-2016
    Dim fso As Object, ts As Object, TempFile As String, 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
    name.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)
    CopyRangeToHTML = ts.ReadAll
    ts.Close
    CopyRangeToHTML = Replace(CopyRangeToHTML, "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

Private Sub send_keys_test()
    'comments out the .HTMLBody section of task_two with this being the test
    msg.GetInspector.Activate
    SendKeys "{Tab}{Tab}{Tab}{Tab}{Tab}", True
    SendKeys "^{End}", True
    tablerng.Copy
    msg.GetInspector.Activate
    SendKeys "^V", True
End Sub

Edit1: + Edit2:

Testing sendkeys with this code, where I stripped out most of the above code to focus on copying the desired range. This does not appear to copy due to the copied range in Excel not displaying the signals for a copy (blinking outline of the range) nor does manually pressing ctrl+V paste anything into Word or Outlook:

Option Explicit

Private tablerng As Range

Private Sub fdsa()
    Set tablerng = Range(Cells(3, 1), Cells(47, 9))
    tablerng.Select
    Application.SendKeys "^c", True 'Edit2:  Once i added "Application." sendkeys worked for me
End Sub

So, I have sendkeys working, due to Application., but still having issues with conditional formatting, despite copy/paste. Hm... Will add some images, before and after conditional formatting...

Before: After:

The blue color, added from conditional formatting is lost when copy/pasting to Outlook via RDB rangetohtml method.

回答1:

You shouldn't need to resort to SendKeys. a slight change to "RDB" so that you 'PasteAll' and conditional formatting seems to transfer fine. Below is a very much pared down example (assuming you have conditional formatting within cells A1:B10)

Sub CreateEmail()
    Dim oApp As Object: Set oApp = CreateObject("Outlook.Application")
    Dim oMail As Object: Set oMail = oApp.CreateItem(olMailItem)

    Dim wsData As Worksheet: Set wsData = ThisWorkbook.Worksheets("Sheet1")
    Dim rData As Range: Set rData = wsData.Range("A1:B10")

    With oMail
        .To = "Test"
        .HTMLBody = _
            "<HTML><body>Content.<br></body></HTML>"
        .HTMLBody = .HTMLBody & RangetoHTML(rData)
        .Display
    End With

End Sub

Function RangetoHTML(rng As Range)
' By Ron de Bruin.
    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
    Application.ScreenUpdating = False
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial xlPasteAll
        .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
    Application.ScreenUpdating = True

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

********* EDIT *********

Not sure why it doesn't work for you. I tested with conditional formatting in place and it copied altered cells into the e-mail.

The RangetoHTML function may be editable to remove the need to copy and paste the range to a new book though [hopefully bypassing the issues as it would use the direct source] (I'm currently at a PC without Outlook though so unable to test my altered code). Please feel free to give it a try and see if it works though.

Function RangetoHTML(rng As Range)
' Altered from code by Ron de Bruin.
    Dim fso As Object, ts As Object
    Dim TempFile As String
    Dim wbSrc As Workbook: Set wbSrc = rng.Worksheet.Parent

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

    'Publish the sheet range to a htm file
    With wbSrc.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=rng.Worksheet.Name, _
         Source:=rng.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=")

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set wbSrc = Nothing
End Function

回答2:

I ended up doing something of far more effort to get around this, due to knowing that .Paragraphs(.Paragraphs.Count).Range.PasteExcelTable False, False, False exists in MS Word.

This was a cumbersome workaround, though I'm attempting to utilize Tragamor's solution before I call this the final product... it works, but it ain't pretty.

Private Sub task_two()
    Set wApp = CreateObject("Word.Application")
    Set doc = wApp.Documents.Add
    With doc
        .content.InsertAfter "Content" & vbNewLine & vbNewLine 
        wApp.Selection.EndKey unit:=wdStory, Extend:=wdMove
        tablerng.Copy
        .Paragraphs(.Paragraphs.Count).Range.PasteExcelTable False, False, False
    End With
End Sub

Private Sub task_three()
    Set oApp = CreateObject("Outlook.Application")
    Set msg = oApp.CreateItem(olMailItem)
    doc.content.Copy
    With msg
        .Display
        .Importance = 2
        .To = ""
        .Subject = "Subject " & sdate
        .GetInspector.WordEditor.content.Paste
        .Attachments.Add ActiveWorkbook.FullName
    End With
End Sub

Private Sub task_four()
    doc.Close SaveChanges:=wdDoNotSaveChanges
    Set doc = Nothing
    wApp.Quit
    Set wApp = Nothing
    Set msg = Nothing
    Set oApp = Nothing
    i = 0
    Set legendrng = Nothing
    Set tablerng = Nothing
    mval = ""
    sdate = ""
    bmonth = ""
    bdate = ""
End Sub

来源：https://stackoverflow.com/questions/56546903/create-email-from-excel-vba-to-include-range-with-conditional-formatting

标签

excel

vba

outlook

conditional-formatting

sendkeys