用于生成电子邮件的Excelmacros只在IDE打开时才起作用

我已经找了几个星期的答案，这让我疯狂：

我有一个macros将特定的单元格复制到Outlook中的新电子邮件。 如果IDE是开放的，它可以完美工作，但通常情况下，如果不是，则将内容粘贴到当前表单中而不是新的电子邮件中。 即使更奇怪的是，有时它会工作，而IDE是closures的，但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 

我试图添加德米特里的build议，但我不知道我是否正确添加它。

 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（将发送指定的input到前台窗口，无论发生什么），粘贴文本使用

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

或者，甚至更好的是，根本不要使用剪贴板，并在Excel中明确地读取当前所选内容的文本，并在Outlook中设置Body属性：

 objMail.Body = rngBody.Text 

Answer 2

我终于弄明白了。 德米特里通过使用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 

它调用了我在微软网站上find的名为“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