Display multiple Outlook emails simultaneously using Excel VBA

Question

The below code cannot display more than around 60-65 emails.

I have around 105 email records to display simultaneously, to send one by one.

1   Sub SendBulkEmail()
2   If Worksheets("BulkEmailTemplate").Range("C200000").End(xlUp).Row <= 1 Then
3       MsgBox ("There are no email ids on the BulkEmailTemplate page. Please add data to execute this code.")
4       Exit Sub
5   End If
6   If ActiveSheet.Range("C4").Value = "" And Application.Caller = "Button 1" Then
7       MsgBox ("The C4 cell above is empty. Please select a word template file that should to be pasted as the email body.")
8       Exit Sub
9   End If
10  Dim OutApp As Outlook.Application
11  Dim OutMail As Outlook.MailItem
12  If Application.Caller = "Button 1" Then
13      Dim wrd As Word.Application
14      Dim doc As Word.Document
15  End If
16  Dim sh As Worksheet
17  
18  With Application
19      .EnableEvents = False
20      .ScreenUpdating = False
21  End With
22  Set sh = Sheets("BulkEmailTemplate")
23  Set OutApp = New Outlook.Application
24  Set wrd = New Word.Application
25  wrd.Visible = False
26  For x = 2 To sh.Cells(Rows.Count, 1).End(xlUp).Row
27      If Application.Caller = "Button 1" Then
28          If x = 52 Or x = 102 Then
29              Set OutApp = New Outlook.Application
30              Set wrd = New Word.Application
31              wrd.Visible = False
32          End If
33          Set doc = wrd.Documents.Open(ActiveSheet.Cells(4, 3).Value)
34          With wrd.Selection.Find
35              .Text = "<<name>>"
36              .Replacement.Text = sh.Cells(x, 1).Value
37              .Execute Replace:=wdReplaceAll
38          End With
39          doc.Content.Copy
40      End If
41      If sh.Cells(x, 2).Value Like "?*@?*.?*" Then
42          Set OutMail = OutApp.CreateItem(olMailItem)
43          Set OutMailAccount = OutApp.Session.Accounts(sh.Cells(x, 2).Value)
44          With OutMail
45              .SendUsingAccount = OutMailAccount
46              .To = sh.Cells(x, 3).Value
47              .CC = sh.Cells(x, 4).Value
48              .Subject = sh.Cells(x, 5).Value  
49              If Application.Caller = "Button 4" Then
50                  .Body = sh.Cells(x, 6).Value
51              End If
52              If Application.Caller = "Button 1" Then
53                  Set Editor = .GetInspector.WordEditor
54                  Editor.Content.Paste
55              End If   
56              If Trim(sh.Cells(x, 7).Value) <> "" Then
57                  If Dir(sh.Cells(x, 7).Value) <> "" Then
58                      .Attachments.Add sh.Cells(x, 7).Value
59                  End If
60              End If
61              .Display
62          End With
63          Set OutMail = Nothing
64          If Application.Caller = "Button 1" Then
65              doc.Close SaveChanges:=False
66              Set doc = Nothing
67              If x = 51 Or x = 101 Then
68                  wrd.Quit
69                  Set wrd = Nothing
70                  Set OutApp = Nothing
71              End If
72          End If
73      End If
74  Next
75  wrd.Quit
76  Set wrd = Nothing
77  Set OutApp = Nothing
78  With Application
79      .EnableEvents = True
80      .ScreenUpdating = True
81  End With
82  MsgBox ("Your draft emails are opened & ready to send")
83  End Sub

The code stops at line number 53, after displaying about 70 odd emails by giving the below error :

Run-time error '-1005567995 (c4104005)':
The operation failed.

enter image description here

Answer 1

Keep in mind that each email embeds a Word editor, and displaying a 100 or so documents can be taxing. You really need to change your design to avoid displaying that many emails. Are users expected to manually edit all of them in a unique way? Probably not - it makes sense to display a prompt for the parameters that the user is expected to edit, but once the user is prompted, just create and send those emails automatically without displaying them all.