Private Sub Application_NewMailEx(ByVal EntryIDCollection As String) Dim mai As Object Dim intInitial As Integer Dim intFinal As Integer Dim strEntryId As String Dim intLength As Integer intInitial = 1 intLength = Len(EntryIDCollection) intFinal = InStr(intInitial, EntryIDCollection, ",") Do While intFinal <> 0 strEntryId = Strings.Mid(EntryIDCollection, intInitial, (intFinal - intInitial)) Set mai = Application.Session.GetItemFromID(strEntryId) intInitial = intFinal + 1 intFinal = InStr(intInitial, EntryIDCollection, ",") Loop strEntryId = Strings.Mid(EntryIDCollection, intInitial, (intLength - intInitial) + 1) Set mai = Application.Session.GetItemFromID(strEntryId) mai.Display 0 End Sub
上面是msdn中的代码，实际只要下面这几句就行了：
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String) Set mai = Application.Session.GetItemFromID(EntryIDCollection) mai.Display 0 End Sub
附加一则：如何将发送人含指定关键字的邮箱直接标记为已读？
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String) Dim vMail As Object Set vMail = Application.Session.GetItemFromID(EntryIDCollection) MsgBox vMail.To & vbCrLf & vMail.CC If contains(vMail.To, "fnst-esf,fnst-esc,fast.au.fujitsu.com") Or contains(vMail.CC, "fnst-esf,fnst-esc,fast.au.fujitsu.com") Then vMail.UnRead = False End If End Sub 'contains("abcdefg","a,bc") will returns true Private Function contains(ByVal s1$, ByVal s2$) As Boolean Dim i%, v v = Split(LCase(s2), ",") s1 = LCase(s1) For i = 0 To UBound(v) If InStr(s1, v(i)) > 0 Then contains = True Exit Function End If Next End Function