Forwarding lots of emails one by one in Outlook using VBA

Question

I am trying to loop through a selection or a folder of Outlook emails, attach the same file to each of them and forward them to the same email address.

I have previously tried to use a for loop but when there were many emails (100+), Outlook told me it ran out of memory and it was unable to forward the emails.

I am try to do this now with a while loop. Below is my code. It is not working. What should I change?

Sub ForwardSelectedItems()

Dim forwardmail As Outlook.mailItem
Dim Selection As Selection
Dim n As Integer
Set Selection = Application.ActiveExplorer.Selection

Set n = Selection.Count

Do While n > 0

    Set forwardmail = Selection.Item(1).forward

    'Email recipient address
    forwardmail.Recipients.Add "test@test.com"

    'File Path 
    forwardmail.Attachments.Add ("C:\temp\test.xlsx")

    forwardmail.Send
Next
End Sub

Answer 1

The below code is working now. I have tried it when there are 80 emails in a subfolder. I am making it looping through a folder instead of a Selection.

Sub SendFolderItemsWithAttachments()

    Dim MyFolder As MAPIFolder
    Set MyFolder = Application.Session.Folders("Name").Folders("Inbox").Folders("Subfolder")

    Dim forwarditems As Items
    Set forwarditems = MyFolder.Items

    Dim i As Long
    For i = forwarditems.Count To 1 Step -1

        Set forwardmail = forwarditems.Item(i).forward

        'Email recipient address
        forwardmail.Recipients.Add "test@test.com"

        'File Path
        forwardmail.Attachments.Add ("C:\Temp\filename.xlsx")

        forwardmail.Send

    Next

End Sub

Answer 2

Set is for objects.

Sub ForwardSelectedItems_V2()

'Dim forwardmail As outlook.mailItem
Dim forwardmail As mailItem
Dim itm As Object

'Dim Selection As Selection
Dim itmSel As Selection

'Dim n As Integer
Dim n As Long

'Set Selection = Application.ActiveExplorer.Selection
Set itmSel = ActiveExplorer.Selection

' Set is for objects
'Set n = Selection.count
n = itmSel.count

Do While n > 0

    ' The first item in the collection "Item(1)" never changes.
    ' This can be used if the first item
    '  is removed from the collection in each iteration.
    ' Not the case here.
    ' Set forwardmail = Selection.Item(1).forward

    Set itm = itmSel.Item(n)

    'If itm is not a mailitem, the object may not have a method you expect.
    If itm.Class = olMail Then

        Set forwardmail = itm.Forward

        'Email recipient address
        forwardmail.Recipients.Add "test@test.com"

        'File Path
        forwardmail.Attachments.Add ("C:\temp\test.xlsx")

        forwardmail.Display
        'forwardmail.Send

    End If

    ' not a For Next loop so n has to be manipulated "manually"
    n = n - 1

'Next
Loop

End Sub