Private WithEvents calItems As Outlook.Items
Private WithEvents personalItems As Outlook.Items
Private WithEvents familyItems As Outlook.Items


Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set calItems = olNS.GetDefaultFolder(olFolderCalendar).Items

' subfolders of default calendar
Set personalItems = olNS.GetDefaultFolder(olFolderCalendar).Folders("Personal").Items
Set familyItems = olNS.GetDefaultFolder(olFolderCalendar).Folders("Family").Items

MsgBox "App Start Started"
End Sub

Private Sub calItems_ItemAdd(ByVal Item As Object)
AddCategories Item
End Sub

Private Sub personalItems_ItemAdd(ByVal Item As Object)
AddCategories Item
End Sub

Private Sub familyItems_ItemAdd(ByVal Item As Object)
AddCategories Item
End Sub


Private Sub AddCategories(ByVal Item As Object)
Dim arrKey
Dim arrCat

'set variable to check for subject, drop to lower case
strCode = LCase(Item.Subject)
Debug.Print strCode

' Set up the array for subjects to match
' Items in arrKey MUST be lowercase !!
arrKey = Array("remote sessie", "service call", "test")
arrCat = Array("MyBusiness", "Service", "Test")

' Go through the array and look for a match, then do something
For i = LBound(arrKey) To UBound(arrKey)
   'MsgBox "Item Processed", , "Message"
   Debug.Print i, InStr(strCode, arrKey(i))
   If InStr(strCode, arrKey(i)) Then
    With Item
     .Categories = arrCat(i)
     .ReminderSet = True
     .Save
    End With
   Exit Sub
   End If
Next i

End Sub