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

我終於明白了。德米特里通過使用一個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 

Answer 2

而不是使用的SendKeys（將發送指定的輸入到前臺窗口，不管它恰好是），貼上使用

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

，或者甚至更好的文本，不要使用剪貼板完全讀取Excel中當前所選內容的文本，並在Outlook中設置Body屬性：

objMail.Body = rngBody.Text