Справочная информация:
Я покопался и научился создавать электронное письмо за Руководство Роба де Брейна , здесь и далее "RDB".Пытаясь получить соответствующее содержимое моего электронного письма, я обнаружил, что созданная RDB функция RangetoHTM не поддерживает цвета, применяемые с помощью conditional formatting.
Я попытался предложить обходной путь, изменив существующий код для включения .Cells(1).PasteSpecial xlPasteAllUsingSourceTheme (предложил здесь ), хотя это также не решает проблему.
Я попытался перейти на использование SendKeys, где я не могу заставить "^V" работать,надеясь, что есть другой способ сделать это.Я попытался выполнить шаг и вручную Ctrl+V, и в нем нет вставляемого содержимого, несмотря на то, что в электронной таблице указан выбранный диапазон.
Проблема:
При копировании диапазона из Excel, который имеет базовую раскраску, а также дополнительную раскраску из условного форматирования, я не могу вставить нужный диапазон в электронное письмо Outlook с помощью кода, поскольку цвета условного форматирования удалены.
Создание изображения (png) диапазона не является приемлемым выводом, поскольку в одном столбце диапазона, который нужно вставить, есть ссылки, по которым нужно следовать.
Вопрос:
Буду признателен за дополнительные предложения, хотя это сделает это субъективным предметом обсуждения, слишком широким для StackOverflow ... поэтому я постараюсь сохранить это специфично для кода, который я создал/modified.
Если кто-нибудь знает, как изменить код RDB, чтобы разрешить условно отформатированные ячейки, это также было бы здорово.
Учитывая, что я пытаюсь SendKeys, кто-нибудь знает, почему я не могу заставить пасту работать?
Код, о котором идет речь:
Примечание: мне пришлось убить имена модулей и удалить некоторое содержимое (стандартное), так что извините за не столь специфические ярлыки начастные подводные лодки называются.В приведенном ниже коде есть пять (5) подпрограмм и одна (1) функция в следующем порядке:
Public Sub execute () ', которая вызывает частные подпрограммы в предпочтительномorder
Private Sub SheetVals () 'устанавливает диапазоны в листе Excel и значения переменных
Private Sub MsgContent ()' Создает электронную почтуи использует значения листа
Private Sub SetToNothing () 'set blah = nothing
Частная функция CopyRangeToHTML (ByVal name As Range)' RDB'sкод
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
Edit1: + Edit2:
Тестирование 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.