共享邮箱newmail事件

leon51

当共享邮箱(附加邮箱,英文additional mailbox或shared mailbox)有新邮件时,检查主题中是否包括特殊字符,若有就自动保存为msg文件。但是是我的个人邮箱收到新邮件触发newmail事件而不是共享邮箱收到新邮件触发。共享邮箱"ABC"建立方法和OK后的效果如下图。请教VBA如何触发共共享文件夹的newmail事件? outlook版本是2003。百度了半天找到一个贴子http://techniclee.wordpress.com/2010/12/16/new-mail-notification-for-an-additional-mailbox/

'以下代码放在"ThisOutlookSession"
Dim objFM1 As FolderMonitor
Private Sub Application_Quit()
    Set objFM1 = Nothing
End Sub
Private Sub Application_Startup()
    Set objFM1 = New FolderMonitor
    objFM1.FolderToWatch OpenOutlookFolder("邮箱 - ABC[ABC邮箱]")   '此句始终有问题，不知如何修改
End Sub
'----------------------------------------------------------------------------------------------------------
'以下代码放在"FolderMonitor"类模块中
Private WithEvents olkItems As Outlook.Items
Private Sub Class_Terminate()
    Set olkItems = Nothing
End Sub
Public Sub FolderToWatch(objFolder As Outlook.Folders)
    Set olkItems = objFolder.Items
End Sub
Private Sub olkItems_ItemAdd(ByVal Item As Object)
    MsgBox "New message arrived!", olkItems.Parent.Name, vbInformation + vbOKOnly + vbSystemModal
End Sub
'----------------------------------------------------------------------------------------------------------
'以下代码放在标准模块中
Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    Dim arrFolders As Variant, varFolder As Variant, bolBeyondRooot As Boolean
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRooot
                Case False
                    Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
                    bolBeyondRooot = True
                Case True
                    Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function