Код ItemAdd перестает срабатывать через час

Question

Мне нужно вызвать код после того, как письмо поступит в почтовый ящик общего почтового ящика.Я попытался Как запустить макрос после запуска нового письма в Outlook? .

Однако этот код прекращает запуск макроса через ровно час.Есть ли что-то, чего мне здесь не хватает.

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")
Dim olRecip As Recipient
Dim Inbox  As Outlook.MAPIFolder

' default local Inbox
Set olRecip = objNS.CreateRecipient("abc@xyz.com")  
Set Inbox = objNS.GetSharedDefaultFolder(olRecip, olFolderInbox)
Set Items = Inbox.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
    OutlookSplit Msg '//call the function OutlookSplit
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub

Function OutlookSplit(myItem2 As Outlook.MailItem)

Dim olApp As Outlook.Application
Dim olNs As Outlook.NameSpace
Dim objOwner As Object
Dim olInbox1 As Outlook.MAPIFolder
Dim lookInbody As String, lookInbody1() As String
Set olApp = Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set objOwner = olNs.CreateRecipient("abc@xyz.com")
Set olInbox1 = olNs.GetSharedDefaultFolder(objOwner, olFolderInbox).Folders("Current")
lookInbody = myItem2.Body
lookInbody1 = Split(lookInbody, vbCrLf)
End Function