Создайте электронную почту из Excel-VBA, чтобы включить диапазон с условным форматированием

Задний план:

Я копался и научился создавать электронную почту для Гид Роба де Брюина, здесь «RDB». Пытаясь привести содержимое моего электронного письма в соответствие, я обнаружил, что созданная RDB функция RangetoHTM не поддерживает цвета, примененные через conditional formatting.

Я попытался предложить обходной путь, изменив существующий код, включив в него .Cells(1).PasteSpecial xlPasteAllUsingSourceTheme (предложенный здесь), хотя это также не решает проблему.

Я попытался перейти к использованию SendKeys, где я не могу заставить "^V" работать, надеясь, что есть другой способ сделать это. Я попытался выполнить пошаговое и ручное Ctrl+V, и вставляемого содержимого нет, несмотря на то, что в электронной таблице указан выбранный диапазон.

Проблема:

При копировании диапазона из Excel, который имеет базовую окраску, а также дополнительную окраску из условного форматирования, я не могу вставить нужный диапазон в электронное письмо Outlook с помощью кода, поскольку цвета условного форматирования удаляются.

Создание изображения (png) диапазона не является приемлемым выходом, так как в одном столбце диапазона, который необходимо вставить, есть ссылки, по которым необходимо перейти.

Вопрос:

Буду признательна за дополнительные предложения, хотя это сделало бы это субъективной дискуссионной частью, которая слишком широка для StackOverflow... поэтому я постараюсь сохранить ее специфичность для кода, который я создал/изменил.

Если кто-нибудь знает, как изменить код RDB, чтобы разрешить ячейки с условным форматированием, это тоже было бы здорово.

Учитывая, что я пытаюсь SendKeys, кто-нибудь знает, почему я не могу заставить пасту работать?

Рассматриваемый код:

Примечание. Мне пришлось изменить имена модулей и удалить некоторый контент (стандартный), так что извините за не очень конкретные ярлыки на вызываемых частных подпрограммах. В приведенном ниже коде есть пять (5) подпрограмм и одна (1) функция в следующем порядке:

• Public Sub execute() 'тот, который вызывает частные сабвуферы в предпочтительном порядке

• Private Sub SheetVals() 'устанавливает диапазоны на листе Excel и значения переменных

• Private Sub MsgContent() ' Создает электронное письмо и использует значения листа

• Private Sub SetToNothing() 'set blah = ничего

• Частная функция CopyRangeToHTML (имя ByVal как диапазон) 'Код RDB

• Private Sub send_keys_test() 'как я пытался сделать 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

Редактировать1: + Редактировать2:

Тестирование sendkeys с помощью этого кода, где я вырезал большую часть приведенного выше кода, чтобы сосредоточиться на копировании нужного диапазона. Это не похоже на копирование из-за того, что скопированный диапазон в Excel не отображает сигналы для копирования (мигающий контур диапазона), а также вручную, нажав Ctrl + V, вставить что-либо в Word или 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

Итак, у меня работают sendkeys из-за Application., но все еще возникают проблемы с условным форматированием, несмотря на копирование/вставку. Хм... Добавлю несколько изображений, до и после условного форматирования...

До: После:

Синий цвет, добавленный из условного форматирования, теряется при копировании/вставке в Outlook методом RDB rangetohtml.