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?

[vba]
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

[/vba]

[JP2112]

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

http://www.jpsoftwaretech.com/outloo...ck-event-code/

Ex:

[vba]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[/vba]

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 ) 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:

[VBA]On Error GoTo ErrorHandler[/VBA]