从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屋！