Show alert for new email in public folder

[MyNameIsMine]

Using Outlook 2007, I'm trying to set up a new email alert for a public mailbox. So far as I can tell, it's impossible to do this with Outlooks tools, so I tried to throw together some code to do this.

Unfortunately, there seems to be at least one problem which makes this code effectively useless. when I switch which mail folder I'm looking at, outlook locks up. Can anybody help me out?


Sub WatchThatBox()
Dim myTime As Date
Dim oMailItem As MailItem
Dim LastTimeRecd As Date
Dim SharedFolder As MAPIFolder
Dim TimeToRun As Date

Set SharedFolder = GetFolder("Mailbox - DFSystemsSupport\InBox")
'it appears that the most recently rec'd item is indexed at 1
'(this is not verified)
If SharedFolder.Items.Count > 0 Then
LastTimeRecd = SharedFolder.Items(1).ReceivedTime
Else
LastTimeRecd = Now()
End If


Do
TimeToRun = Now + TimeValue("00:00:10")
Do While Now < TimeToRun
'I have a feeling that DoEvents doesn't work quite like I think it does...
DoEvents
Loop
If SharedFolder.Items.Count > 0 Then
myTime = SharedFolder.Items(1).ReceivedTime
If myTime > LastTimeRecd Then
'this stops the code from continuing, but I don't really care if I get one alert
'per message, I just want to know if there's anything in the folder at all
'without having to remember to check.
MsgBox "New item In MailBox!!!", vbMsgBoxSetForeground + vbExclamation, _
"WORK WORK WORK WORK"
LastTimeRecd = myTime
End If
End If
Loop

End Sub

Public Function GetFolder(strFolderPath As String) As MAPIFolder
'From www .outlookcode.com
' strFolderPath needs to be something like
' "Public Folders\All Public Folders\Company\Sales" or
' "Personal Folders\Inbox\My Folder"
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim I As Long
On Error Resume Next
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objApp = Application
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For I = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(I))
If objFolder Is Nothing Then
Exit For
End If
Next
End If
Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Function

[JP2112]

Attach an event handler to the Inbox you want to monitor for new emails.

http://www.jpsoftwaretech.com/outlook-vba/stock-event-code/

Ex:

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")
' public Inbox
Set Items = objNS.Folders("Mailbox - DFSystemsSupport").Folders("Inbox").Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
MsgBox "New item In MailBox!!!", vbMsgBoxSetForeground + vbExclamation, _
"WORK WORK WORK WORK"
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub

After putting this code into ThisOutlookSession, you must restart Outlook. Whenever a new item is added to the specified folder, you will see the message box.

[MyNameIsMine]

Thanks, JP.

Somehow, I didn't even think about a WithEvents event handler -- probably because I've only had to define my own once in the last 3 years (if only I could retain everything I've ever read :sigh: ) Definitely makes this type of thing a lot easier.

Minor clarifiction: I'm assuming that Sub Items_ItemAdd requires an "On Error goto" wrapper, and isn't some nifty shortcut I don't know about?

[JP2112]

Yes, in my haste to copy and paste I accidently took out this line at the top of the procedure:

On Error GoTo ErrorHandler