从 Excel-VBA 创建电子邮件以包含具有条件格式的范围 [英] Create email from Excel-VBA to include Range with Conditional Formatting

查看：20 发布时间：2021/12/30 9:48:04 excel vba outlook conditional-formatting sendkeys

本文介绍了从 Excel-VBA 创建电子邮件以包含具有条件格式的范围的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！

问题描述

背景:

我仔细研究并学会了根据之后:

通过 RDB rangetohtml 方法复制/粘贴到 Outlook 时，从条件格式添加的蓝色丢失.

解决方案

您不应该求助于 SendKeys.对RDB"稍作更改，以便PasteAll"和条件格式似乎可以正常传输.下面是一个非常精简的示例(假设您在单元格 A1:B10 中有条件格式)

Sub CreateEmail()Dim oApp As Object: Set oApp = CreateObject("Outlook.Application")Dim oMail 作为对象:设置 oMail = oApp.CreateItem(olMailItem)将 wsData 调暗为工作表:设置 wsData = ThisWorkbook.Worksheets("Sheet1")Dim rData As Range: Set rData = wsData.Range("A1:B10")使用 oMail.To = "测试".HTMLBody = _<HTML><body>内容.<br></body></HTML>".HTMLBody = .HTMLBody &RangetoHTML(rData).展示结束于结束子函数 RangetoHTML(rng As Range)' 罗恩·德·布鲁因 (Ron de Bruin).将 fso 调暗为对象将 ts 作为对象Dim TempFile 作为字符串Dim TempWB 作为工作簿TempFile = Environ$("temp") &"/" &格式(现在，dd-mm-yy h-mm-ss")&.htm"'复制范围并创建一个新的工作簿以将数据传递到Application.ScreenUpdating = Falserng.复制设置 TempWB = Workbooks.Add(1)使用 TempWB.Sheets(1).Cells(1).PasteSpecial xlPasteAll.Cells(1).选择Application.CutCopyMode = False出错时继续下一步.DrawingObjects.Visible = True.DrawingObjects.Delete出错时转到 0结束于'将工作表发布到 htm 文件使用 TempWB.PublishObjects.Add( _SourceType:=xlSourceRange, _文件名:=临时文件，_Sheet:=TempWB.Sheets(1).Name, _来源:=TempWB.Sheets(1).UsedRange.Address, _HtmlType:=xlHtmlStatic).发布(真)结束于'将 htm 文件中的所有数据读入 RangetoHTMLSet fso = CreateObject("Scripting.FileSystemObject")设置 ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)RangetoHTML = ts.ReadAllts.关闭RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _"align=left x:publishsource=")'关闭TempWBTempWB.Close savechanges:=FalseApplication.ScreenUpdating = True'删除我们在这个函数中使用的htm文件杀死临时文件设置 ts = 无设置 fso = 无设置 TempWB = 无结束函数

********* 编辑 *********

不知道为什么它不适合你.我使用适当的条件格式进行了测试，并将更改后的单元格复制到电子邮件中.

RangetoHTML 函数可能是可编辑的，以消除将范围复制并粘贴到新书的需要，尽管 [希望绕过这些问题，因为它会使用直接来源](我目前在没有 Outlook 的 PC 上，尽管如此无法测试我修改过的代码).请随意尝试一下，看看它是否有效.

函数 RangetoHTML(rng As Range)' 由 Ron de Bruin 从代码中更改.Dim fso 作为对象，ts 作为对象Dim TempFile 作为字符串Dim wbSrc 作为工作簿:设置 wbSrc = rng.Worksheet.ParentTempFile = Environ$("temp") &"/" &格式(现在，dd-mm-yy h-mm-ss")&.htm"'将工作表范围发布到 htm 文件使用 wbSrc.PublishObjects.Add( _SourceType:=xlSourceRange, _文件名:=临时文件，_工作表:=rng.Worksheet.Name，_来源:=rng.Address, _HtmlType:=xlHtmlStatic).发布(真)结束于'将 htm 文件中的所有数据读入 RangetoHTMLSet fso = CreateObject("Scripting.FileSystemObject")设置 ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)RangetoHTML = ts.ReadAllts.关闭RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _"align=left x:publishsource=")'删除我们在这个函数中使用的htm文件杀死临时文件设置 ts = 无设置 fso = 无设置 wbSrc = 无结束函数

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.

解决方案

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

这篇关于从 Excel-VBA 创建电子邮件以包含具有条件格式的范围的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！

查看全文

从 Excel-VBA 创建电子邮件以包含具有条件格式的范围 [英] Create email from Excel-VBA to include Range with Conditional Formatting

问题描述

相关文章

其他开发最新文章

热门教程

热门工具

登录关闭

从 Excel-VBA 创建电子邮件以包含具有条件格式的范围 [英] Create email from Excel-VBA to include Range with Conditional Formatting

问题描述

相关文章

其他开发最新文章

热门教程

热门工具

登录 关闭

登录关闭