用于生成电子邮件的Excel宏只有在IDE打开时才能工作

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

我试着添加德米特里的建议，尽管我不确定我添加得是否正确。

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

我终于想通了。Dmitry使用HTML文件而不是简单的副本/SendKeys是正确的。

这是新代码：

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