Add attachment to all selected items in Outlook 2016 with VBA - vba

Question

I aim to add an attachment to every item that is currently selected in Outlook 2016. My idea is to call Attachments.Add in a loop on each item in the current selection.
In my Drafts folder, I have three drafts with the subjects:
Draft Test 3
Draft Test 2
Draft Test 1
Because of the environment that I am in, I cannot use C#. I am using VBA instead. I ran all the test code by clicking Developer > Macros > [sub name] in the Outlook 2016 ribbon.
I started with this:
Sub AddTestTxtToSelection1()
Dim i As Long
With Application.ActiveExplorer.Selection
For i = .Count To 1 Step -1
.Item(i).Attachments.Add "C:\Full\Path\To\Test.txt", olByValue, 1
Next
End With
End Sub
Unfortunately, Test.txt was only attached to Draft Test 3 although all three drafts were selected. I thought that I might be iterating through the selection incorrectly, so I tried this:
Sub AddTestTxtToSelection2()
For Each objMessage In Application.ActiveExplorer.Selection
objMessage.Attachments.Add "C:\Full\Path\To\Test.txt", olByValue, 1
Next
End Sub
Again, although all three drafts were selected, Test.txt was only attached to Draft Test 3. In the example code in this article, Application.ActiveExplorer and its Selection property are stored in separate variables. I thought that that might have been what was missing, so I wrote this:
Sub AddTestTxtToSelection3()
Dim myOlExp As Explorer
Dim myOlSel As Selection
Set myOlExp = Application.ActiveExplorer
Set myOlSel = myOlExp.Selection
Dim i As Long
For i = 1 To myOlSel.Count
myOlSel.Item(i).Attachments.Add "C:\Full\Path\To\Test.txt", olByValue, 1
Next
End Sub
The behavior was identical to that of the first two tests. Finally, it occurred to me that the problem might be with modifying the drafts as I was looping over them. I then wrote this code, which stores the EntryID properties of the selected items in a separate string array before looping over them:
Sub AddTestTxtToSelection4()
Dim i As Long
Dim strEntryID As Variant
Dim namespaceMAPI As NameSpace
Dim objMessage As Object
Dim selected() As String
' Copy the current selection into an array of EntryID strings.
ReDim selected(1 To Application.ActiveExplorer.Selection.Count) As String
For i = 1 To Application.ActiveExplorer.Selection.Count
selected(i) = Application.ActiveExplorer.Selection.Item(i).EntryID
Next
' Retrieve each item from its EntryID string.
Set namespaceMAPI = Application.GetNamespace("MAPI")
namespaceMAPI.Logon
For Each strEntryID In selected
Set objMessage = namespaceMAPI.GetItemFromID(strEntryID)
objMessage.Attachments.Add "C:\Full\Path\To\Test.txt", olByValue, 1
Next
End Sub
Again, only Draft Test 3 had Test.txt attached after running this code. I thought that Outlook might be having trouble attaching the same file to multiple drafts, so I modified the last test to attach a different file to each draft. Only Draft Test 3 had an attachment after it was executed. Even if I swap out Application.ActiveExplorer.Selection for Application.ActiveExplorer.CurrentFolder.Items, still only the first draft gets an attachment.
Why can't Outlook attach a file to more than one mail item at a time? Is there a workaround?

Answer 1

Certain actions require a .Save.
There is likely a correlation with actions that require a save when done manually. In this case if you were to manually attach a file then close the draft you would be asked if the draft should be saved.

Answer 2

I have accepted #niton's answer, but here is my code after adding .Save:
' Based on AddTestTxtToSelection2
Sub AddTestTxtToSelection5()
For Each objMessage In Application.ActiveExplorer.Selection
objMessage.Attachments.Add "C:\Full\Path\To\Test.txt", olByValue, 1
objMessage.Save ' This line was added.
Next
End Sub
The attachments get added to every selected message now.