对我有用的outlook vba

OutlookVBA开发第八讲 -按发件人自动分类邮件
(如有问题，请联系dsd999@sohu.com)
需求：按发件人自动分类邮件，收到新邮件时，以发件人的名字在收件箱下建目录，然后把新邮件移动到此目录下。
准备： Alt + F11 打开 VBA的编辑器，然后双击左边的ThisOutlookSession，右边选择Application，Startup。如图：
把下面的代码复制到后面。
代码：
Private Sub Application_NewMailEx(ByValEntryIDCollection As String)
On Error Resume Next
Dim myNamespace As Object
Dim obInbox As Object
Dim mai As Object
Dim intInitial As Integer
Dim intFinal As Integer
Dim strEntryId As String
Dim intLength As Integer
Dim temp As Object
Dim mlItem As Outlook.mailItem
Dim replyItem As Outlook.mailItem
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)
Set myNamespace = Application.GetNamespace("MAPI")
Set obInbox = myNamespace.GetDefaultFolder(olFolderInbox)
If mai.Class = 43 Then
Set mlItem = mai
Set temp = Nothing
Set temp = obInbox.Folders.Item(mlItem.SenderName)
If temp Is Nothing Then
Set temp = obInbox.Folders.add(mlItem.SenderName)
End If
mlItem.Move temp
End If
End Sub
感谢版主 dsd999