Items_ItemAdd(ByVal Item As Object) is not processing multiple items that come in at the same time - vba

Question

If only one email is sent at a time then my code works fine, otherwise, if multiple items come in at the same time then only one of the emails is processed and moved. Basically, my code is processing items as they come into outlook. And if the email is received as a distribution list then the email is sent to a sub folder based on the distribution list name and time of day.
Here's my code:
Private WithEvents Items As Outlook.Items
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_ItemAdd(ByVal cusItem As Object)
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
Dim strEntryID As String
Dim objAddressentry As Outlook.AddressEntry
Dim objRecipient As Outlook.Recipient
Dim objDestFolder As Outlook.MAPIFolder
Dim objRecs As Outlook.Recipients
Dim i As Integer
If TypeName(cusItem) = "MailItem" Then
On Error GoTo ErrorHandler
Set objRecs = cusItem.Recipients
For i = 1 To objRecs.Count
Set objRecipient = objRecs.Item(i)
strEntryID = objRecipient.EntryID
Set objAddressentry = objNS.GetAddressEntryFromID(strEntryID)
If objAddressentry = "amazonselling" And TimeValue(Now()) >= TimeValue("08:00:00 AM") And TimeValue(Now()) <= TimeValue("05:00:00 PM") Then
Set objDestFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("ryule")
cusItem.Move objDestFolder
Exit For
End If
Next
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description & vbCrLf & "Click Ok to continue operations"
Resume ProgramExit
End Sub
Also, if I don't declare and set those variables twice then my code doesn't work as intended. Why is that and how could that be fixed?

Answer 1

The ItemAdd event is not fired when a large number of items are added to the folder at once (more than sixteen). This is a known issue when dealing with the Outlook object model. Instead, I'd suggest considering the NewMailEx event which is fired when a new message arrives in the Inbox and before client rule processing occurs. You can use the Entry ID returned in the EntryIDCollection array to call the NameSpace.GetItemFromID method and process the item.
Anyway, it seems the problem is in your code, try to remove additional declarations from both methods:
Private WithEvents Items As Outlook.Items
Private objNS As Outlook.NameSpace
Private Sub Application_Startup()
Set objNS = Application.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal cusItem As Object)
Dim strEntryID As String
Dim objAddressentry As Outlook.AddressEntry
Dim objRecipient As Outlook.Recipient
Dim objDestFolder As Outlook.MAPIFolder
Dim objRecs As Outlook.Recipients
Dim i As Integer
If TypeName(cusItem) = "MailItem" Then
On Error GoTo ErrorHandler
Set objRecs = cusItem.Recipients
For i = 1 To objRecs.Count
Set objRecipient = objRecs.Item(i)
strEntryID = objRecipient.EntryID
Set objAddressentry = objNS.GetAddressEntryFromID(strEntryID)
If objAddressentry = "amazonselling" And TimeValue(Now()) >= TimeValue("08:00:00 AM") And TimeValue(Now()) <= TimeValue("05:00:00 PM") Then
Set objDestFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("ryule")
cusItem.Move objDestFolder
Exit For
End If
Next
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description & vbCrLf & "Click Ok to continue operations"
Resume ProgramExit
End Sub