Outlook Add Items quits working - Items_ItemAdd(ByVal Item As Object)

Question

I am watching for new items and then calling a subroutine. In place of the subroutine, I am currently using a message box for testing.

Initially the code worked properly. After running it a few times, it quit working. If I shut down Outlook and reopened it would work again a few more times. I searched many sites for answers.

I tried backing up the project file, deleting it, restoring it. I was able to use this code again for awhile. Now I can't get it to work, regardless of what I do. I have been working on this for two days, but I cannot understand what is going wrong. I'm running Outlook 2010 and my code is posted below.

The code is saved in This Outlook Session:

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")
  ' default local Inbox
  Set Items = objNS.GetDefaultFolder(olFolderInbox).Folders("Access Data Collection Replies").Items
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
    ' ******************
    ' This is going to be the code to respond to the dealer and to call   procedures. Maybe it can be handled with case statements.  Then each event can be identified.
    ' ******************
    MsgBox("It Worked!")
    Call AnswerD

  End If
ProgramExit:
  Exit Sub
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description
  Resume ProgramExit
End Sub

Answer 1

your code works find, if you are trying to get the msg box to pop then

Move this line code

MsgBox ("It Worked!")

next to

  If TypeName(item) = "MailItem" Then
      MsgBox ("It Worked!")

here is complete code tested on Outlook 2010

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
    Dim olNameSpace     As Outlook.NameSpace

    Set olNameSpace = Application.GetNamespace("MAPI")
    '// ' Default local Inbox (olFolderInbox) & sub ("Folder Name")
    Set Items = olNameSpace.GetDefaultFolder(olFolderInbox).Folders("Access Data Collection Replies").Items
End Sub

Private Sub Items_ItemAdd(ByVal item As Object)
    If TypeOf item Is Outlook.MailItem Then
        MsgBox ("It Worked!")
        'AnswerD '<-- un-comment to call subroutine.
    End If
End Sub

Private Sub SaveMovePrint(OlMail As Outlook.MailItem)
    'On Error GoTo ErrorHandler
    ' ******************
    ' Here subroutine
    ' ******************
ProgramExit:
  Exit Sub
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description
  Resume ProgramExit
End Sub