Add attachment to all selected items in Outlook 2016 with 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.