Question

我已经为这几周寻找答案了，这让我发疯了：

我有一个宏将特定单元格复制到Outlook中的新电子邮件中。如果IDE处于打开状态，它可以很好地工作，但通常情况下，它不会将内容粘贴到当前工作表而不是新电子邮件中。甚至更奇怪的是，有时它会在IDE关闭时起作用，但99％的时间它都会失败，这使得它成为诊断的噩梦。

它让我发疯，你们是我唯一的希望！

Sub EmailReports()
    Dim rngSubject As Range
    Dim rngTo As Range
    Dim rngBody As Range
    Dim objOutlook As Object
    Dim objMail As Object

    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)

    xRow = ActiveCell.Row
    RMName = Sheets("Dashboard").Range("B" & xRow)
    LastTaskRow = Sheets(RMName).Range("A1")

    With Target
    Range("E" & xRow) = Format(Now(), "MM/DD/YYYY")
    End With



    Set rngTo = Range("C" & xRow)
    Set rngSubject = Worksheets("Dashboard").Range("K4")
    Set rngBody = Worksheets(RMName).Range("D4:E" & LastTaskRow)

    rngBody.Copy


    With objMail
        .To = rngTo
        .Subject = rngSubject
        .Display
    End With

    SendKeys "^({v})", True

    Set objOutlook = Nothing
    Set objMail = Nothing



End Sub

我尝试添加Dmitry的建议，但我不确定我是否正确添加了它。

Sub EmailReports()
    Dim rngSubject As Range
    Dim rngTo As Range
    Dim rngBody As Range
    Dim objOutlook As Object
    Dim objMail As Object

    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)

    xRow = ActiveCell.Row
    RMName = Sheets("Dashboard").Range("B" & xRow)
    LastTaskRow = Sheets(RMName).Range("A1")

    With Target
    Range("E" & xRow) = Format(Now(), "MM/DD/YYYY")
    End With



    Set rngTo = Range("C" & xRow)
    Set rngSubject = Worksheets("Dashboard").Range("K4")
    Set rngBody = Worksheets(RMName).Range("D4:E" & LastTaskRow)

    rngBody.Copy


    With objMail
        .To = rngTo
        .Subject = rngSubject
        .Display
    End With

    Set objHTML = CreateObject("htmlfile")
    ClipboardText = objHTML.ParentWindow.ClipboardData.GetData("text")
    objMail.Body = rngBody.Text


    Set objOutlook = Nothing
    Set objMail = Nothing



End Sub

Answer 1

不使用SendKeys（将指定的输入发送到前台窗口，无论它发生什么），而是使用

粘贴文本

Set objHTML = CreateObject("htmlfile")
ClipboardText = objHTML.ParentWindow.ClipboardData.GetData("text")
objMail.Body = ClipboardText

或者，更好的是，根本不使用剪贴板并显式读取Excel中当前选择的文本并在Outlook中设置Body属性：

objMail.Body = rngBody.Text

Answer 2

我终于明白了。通过使用HTML文件而不是简单的副本/ SendKeys，Dmitry走在正确的轨道上。

这是新代码：

Sub EmailReports()
Dim rngSubject As Range
Dim rngTo As Range
Dim rngBody As Range
Dim objOutlook As Object
Dim objMail As Object

Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)

xRow = ActiveCell.Row
RMName = Sheets("Dashboard").Range("B" & xRow)
LastTaskRow = Sheets(RMName).Range("A1")

With Target
Range("E" & xRow) = Format(Now(), "MM/DD/YYYY")
End With


Set rngTo = Range("C" & xRow)
Set rngSubject = Worksheets("Dashboard").Range("K4")
Set rngBody = Worksheets(RMName).Range("D4:E" & LastTaskRow)

With objMail
    .To = rngTo
    .Subject = rngSubject
    .HTMLBody = RangetoHTML(rngBody)
    .Display
End With


Set objOutlook = Nothing
Set objMail = Nothing



End Sub

它正在调用我在微软网站上发现的一个名为“RangetoHTML”的函数：

Function RangetoHTML(rng As Range)
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    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 workbook to receive the data.
    rng.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 an .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 the RangetoHTML subroutine.
    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

    ' Delete the htm file.
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

用于生成电子邮件的Excel宏仅在IDE打开时有效

2 个答案: