从Excel-VBA创建电子邮件以包含条件格式的范围 [英] Create email from Excel-VBA to include Range with Conditional Formatting
问题描述
背景:
我已经研究并学会了根据 Rob de Bruin的指南创建电子邮件,此处为"RDB".在尝试获取适当的电子邮件内容时,我发现RDB创建的RangetoHTM函数不能保留通过conditional formatting
施加的颜色.
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
.
我尝试了一种建议的解决方法,将现有代码更改为包括.Cells(1).PasteSpecial xlPasteAllUsingSourceTheme
(建议
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.
我尝试使用SendKeys
继续前进,但我无法让"^V"
正常工作,希望有另一种方法可以做到这一点.尽管电子表格列出了选定的范围,但我还是尝试手动完成Ctrl+V
并没有可粘贴的内容.
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.
问题:
从Excel复制范围时,该范围具有基本颜色以及条件格式的其他颜色,由于条件格式颜色被删除,我无法通过代码将所需范围粘贴到Outlook电子邮件中.
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.
生成该范围的图像(png)是不可接受的输出,因为在要粘贴的范围的一列中需要遵循链接.
问题:
我们将不胜感激其他建议,尽管这会使它成为一个主观的,讨论性的话题,对于StackOverflow来说太宽泛了……所以我将尽力使它针对我创建/修改的代码.
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.
如果有人知道如何修改RDB的代码以允许条件格式化的单元格,那也将很棒.
If anyone is aware how to modify RDB's code to allow conditionally formatted cells, that would also be awesome.
鉴于我正在尝试SendKeys
,有人知道为什么我无法使粘贴生效吗?
Given I am attempting SendKeys
, does anyone know why I cannot get the paste to work?
相关代码:
注意:我不得不混用模块名称并删除一些内容(标准),所以请原谅被调用的私有潜艇上不是那么具体的标签.以下代码中按此顺序有五(5)个子例程和一(1)个函数:
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()'以首选顺序调用私人潜艇的那个
Public Sub execute() 'the one that calls the private subs in the preferred order
Private Sub SheetVals()'设置Excel工作表中的范围和值变量
Private Sub SheetVals() 'sets the ranges in the excel sheet and values variables
私人Sub MsgContent()'创建电子邮件并使用表格vals
Private Sub MsgContent() ' Creates the email and uses the sheet vals
Private Sub SetToNothing()'set blah = none
Private Sub SetToNothing() 'set blah = nothing
私有函数CopyRangeToHTML(ByVal名称作为范围)'RDB的代码
Private Function CopyRangeToHTML(ByVal name As Range) 'RDB's code
私人子send_keys_test()'我一直在尝试做sendkeys
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
+
+
使用此代码测试sendkey,在这里我剥离了大部分上面的代码,专注于复制所需的范围.由于Excel中已复制的范围未显示副本的信号(范围的闪烁轮廓),因此这似乎没有被复制,也没有手动按ctrl + V将任何内容粘贴到Word或Outlook中:
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
因此,由于Application.
,我的sendkey正常工作,但是尽管有复制/粘贴,但条件格式设置仍然存在问题.嗯...将在条件格式化前后添加一些图像...
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...
之前:之后:
通过RDB rangetohtml方法复制/粘贴到Outlook时,从条件格式中添加的蓝色会丢失.
The blue color, added from conditional formatting is lost when copy/pasting to Outlook via RDB rangetohtml method.
推荐答案
您不需要诉诸SendKeys.对"RDB"稍作更改,以便您使用"PasteAll"和条件格式似乎可以正常运行.下面是一个非常精简的示例(假设您在单元格A1:B10中具有条件格式)
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.
RangetoHTML函数可能是可编辑的,以消除复制和粘贴范围到新书的需要,尽管[希望绕过这些问题,因为它将使用直接来源](我目前在没有Outlook的PC上,但是无法测试我修改过的代码).请随时尝试一下,看看它是否可以工作.
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
这篇关于从Excel-VBA创建电子邮件以包含条件格式的范围的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!