VBA Excel - Pasting content from a excel range to an outlook email.

Question

I would like to loop through the VBA code below. However, it can only run once and I encounter a "Run-time error '5097': Word has encountered a problem" if I try to run it more than once.

I can run the code again if I restart outlook but fail again second time.

Sub CopyRangeToOutlookEmail()

Dim rng As Range 

Dim OutlookApp As Object 

Dim outlookMail As Object 

Dim editor As Object 

Dim olInspector As Outlook.Inspector 

Set rng = ThisWorkbook.Sheets("Sheet1").Range("A1:D10") ' Change the sheet name and range as per your requirement 

Set OutlookApp = CreateObject("Outlook.Application") 

Set outlookMail = OutlookApp.CreateItem(0) 

rng.Copy 

outlookMail.GetInspector.wordEditor.Windows(1).Selection.PasteAndFormat (wdFormatOriginalFormatting) 

outlookMail.Display 

Set rng = Nothing 

Set OutlookApp = Nothing 

Set outlookMail = Nothing 

End Sub

Answer 1

Adding "On Error Resume Next" allows the code to run without stopping on errors, but the range is not being pasted in the email body.

However, it works if I add "SendKeys "%V"" after ".Display". This is like simulating a click on Outlook somewhere.

Answer 2

I have tested your code at my side. It works without any error for the second time.

You may try running it on another machine.

You may use F8 to run code step by step to check which line get this error. Sometimes a simple restarting computer will resolve some unknown issue.

Answer 3

Thank you! However, when I try it on another PC, it shows me another error: '4198' Command failed.

I can run GetInspector many times in one email using CreateItem(0). However, it fails after I call a new CreateItem(0) as below.

Alternatively, I can try running it again when I physically do something in Outlook.

I suspect that I may need to reset the inspect, wordeditor, or some object, but how can I do that?

Sub CopyRangeToOutlookEmail()

Dim rng As Range 

Dim OutlookApp As Object 

Dim outlookMail As Object 

Dim editor As Object 

Dim olInspector As Outlook.Inspector 

Set rng = ThisWorkbook.Sheets("Sheet1").Range("A1:D10") 

Set rng2 = ThisWorkbook.Sheets("Sheet1").Range("F1:J10") 

Set OutlookApp = CreateObject("Outlook.Application") 

Set outlookMail = OutlookApp.CreateItem(0) 

rng.Copy 

outlookMail.GetInspector.wordEditor.Windows(1).Selection.PasteAndFormat (wdFormatOriginalFormatting) 

rng2.Copy 

outlookMail.GetInspector.wordEditor.Windows(1).Selection.PasteAndFormat (wdFormatOriginalFormatting) 

outlookMail.Display 

Set OutlookApp = Nothing 

Set outlookMail = Nothing 

Application.CutCopyMode = False 

Set OutlookApp = CreateObject("Outlook.Application") 

Set outlookMail = OutlookApp.CreateItem(0) 

rng.Copy 

outlookMail.GetInspector.wordEditor.Windows(1).Selection.PasteAndFormat (wdFormatOriginalFormatting) 

rng2.Copy 

outlookMail.GetInspector.wordEditor.Windows(1).Selection.PasteAndFormat (wdFormatOriginalFormatting) 

outlookMail.Display 

End Sub

Answer 4

Your code still works at my side, It create two outlook mail each time.

You may try adding this line before your code.

On Error Resume Next