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

几个星期以来，我一直在寻找答案，这让我发疯：

我有一个宏，可以将特定单元格复制到Outlook中的新电子邮件中。如果IDE是打开的，它可以完美地工作，但通常情况下，如果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

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

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

或者，最好不要使用剪贴板，在Excel中显式读取当前选定内容的文本，并在Outlook中设置Body属性：

objMail.Body = rngBody.Text

---

我终于明白了。Dmitry通过使用HTML文件而不是简单的复制/发送键，走上了正确的道路

以下是新代码：

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”的函数：

---

非常感谢你的帮助，德米特里！我试着在SendKeys以前的位置添加它。它现在给我一个错误。“类型不匹配：无法强制参数。Outlook无法转换字符串。”我是否将其添加到错误的空间？另外，will.Text会保留我在体单元格上的格式吗？你不需要同时使用我的两个建议。只有一个可以。第二个更好。哪一行代码会引发错误？我尝试用您的第二个建议替换SendKeys。我在那一行收到一个错误：“运行时错误：类型不匹配：无法强制参数值。Outlook无法转换字符串。”这可能是因为它选择了一个单元格范围而不是单个值吗？是否可以插入以下行？它显示了什么？MSGBoxTypeName（rngBody.Text）Hmmm。。我不是一个优秀的专家。。。。你能试试第一个建议（用剪贴板）吗？

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