How can I copy every unread message from default inbox to a shared folder?

Question

I'm trying to organize 10+ different mailboxes.

The problem is with UnreadMove. I want every time Outlook opens to look for unread mails in the default inbox, copy it and move one of the copies to a shared inbox.

It works if there is one mail to move, but when there are more I get an error

"-2147221241 - Failed Client Action"

or something similar. My Windows is not in English.

When I press ok on the failure window the mails are still copied and moved to the correct folder, so I don't know what the error means. Some mails are copying twice, so might be what the error stands for.

MoveAndCopy: incoming mail is copied and sent to the shared inbox and is marked as read in the original folder (this works).
UnreadMove: should be used when Outlook has not been open for a while and the original inboxes got new mails. Then I want the unread e-mails to be copied, marked as read and then a copy sent to the shared inbox, which should not be marked as read.

ThisOutlookSession

Private Sub Application_Startup()

Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace

Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")

Set Items = objNS.GetDefaultFolder(olFolderInbox).Items

End Sub

Private Sub Items_UnreadMove(ByVal Item As Object)

Dim msg As Outlook.MailItem

    If Item.Exists = True Then
        Set msg = Item
        Call UnreadMove(Item)
    End If
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)

On Error GoTo ErrorHandler
Dim msg As Outlook.MailItem

    If TypeName(Item) = "MailItem" Then
        Set msg = Item
        Call MoveAndCopy(Item)
    End If

ProgramExit:
Exit Sub

ErrorHandler:
MsgBox Err.Number & " - " & Err.Description

Resume ProgramExit
End Sub

And for the two modules:

Sub UnreadMove(Item As Outlook.MailItem)

Dim Inbox As Outlook.Folder
Dim ns As Outlook.NameSpace
Dim MailDest As Outlook.Folder
Dim CopiedItem As Outlook.MailItem

Set Inbox = ns.GetDefaultFolder(olFolderInbox)

For Each Item In Inbox
    If Item.UnRead = True Then
        Set CopiedItem = Item.Copy
        Item.UnRead = False
        Item.Save
        Set ns = Outlook.Application.GetNamespace("MAPI")
        Set MailDest = ns.Folders("myemail@test.com").Folders("MyInbox")
        CopiedItem.Move MailDest
    End If
Next Item

End Sub
Sub MoveAndCopy(Item As Outlook.MailItem)

Dim ns As Outlook.NameSpace
Dim MailDest As Outlook.Folder
Dim CopiedItem As Outlook.MailItem
    
    If Item.Class = olMail Then
        Set CopiedItem = Item.Copy
        Item.UnRead = False
        Item.Save
        Set ns = Outlook.Application.GetNamespace("MAPI")
        Set MailDest = ns.Folders("myemail@test.com").Folders("MyInbox")
        CopiedItem.Move MailDest
    End If
    
End Sub

Answer 1

UnreadMove makes a copy in the monitored folder. It would invoke Items_ItemAdd. The same for MoveAndCopy.

Whether this is the cause of the error you see now, this should do what you want.

Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant

Private WithEvents monitoredItems As Items

Private Sub Application_Startup()
    UnreadMove
    Set monitoredItems = Session.GetDefaultFolder(olFolderInbox).Items
End Sub


Sub UnreadMove()

    Dim Inbox As folder
    Dim MailDest As folder
    Dim CopiedItem As MailItem

    Dim objItem As Object

    Set Inbox = Session.GetDefaultFolder(olFolderInbox)

    Set MailDest = Session.folders("myemail@test.com").folders("MyInbox")

    ' Copying invokes itemAdd
    ' If you run this manually,
    '   after setting up monitoredItems in startup
    '  - a trick to turn itemAdd off
    Set monitoredItems = Nothing

    '
    'For Each objItem In Inbox.Items
    
    '    If objItem.Class = olMail Then
    
    '        If objItem.UnRead = True Then
    '            Debug.Print objItem.subject
    '
    '            Set CopiedItem = objItem.copy
    '            objItem.UnRead = False
    '            objItem.Save
                        
    '            CopiedItem.Move MailDest
            
    '        End If
        
    '    End If
    
    'Next objItem

    ' If the For Each index is confused by copying and moving
    '  Then a reverse For Next is needed.
    '  A reverse loop works in all situations.
    Dim i As Long
    For i = Inbox.Items.count To 1 Step -1
    
        Set objItem = Inbox.Items(i)
    
        If objItem.Class = olMail Then
    
            If objItem.UnRead = True Then
                Debug.Print objItem.subject
            
                Set CopiedItem = objItem.copy
                objItem.UnRead = False
                objItem.Save
            
                CopiedItem.Move MailDest
            
            End If
        
        End If
    
    Next

    ' reset items to be monitored with itemAdd
    Set monitoredItems = Session.GetDefaultFolder(olFolderInbox).Items

End Sub

To temporarily stop monitoring, when you make a copy in the monitored folder.

Private Sub monitoredItems_ItemAdd(ByVal Item As Object)

    Dim msg As MailItem

    If TypeName(Item) = "MailItem" Then
        Set msg = Item
        Set monitoredItems = Nothing
        
        'Call MoveAndCopy(Item)
                
        Call MoveAndCopy(msg)
        ' or
        ' MoveAndCopy msg
        Set monitoredItems = Session.GetDefaultFolder(olFolderInbox).Items

    End If

End Sub

You could stop monitoring in MoveAndCopy instead, if you wish to be more specific.