Outlook 收件人列表特出显示

leucine

简单写了一下vba，进入outlook后，按alt+f11，在ThisOutlookSession里面粘帖以下代码，记得把宏安全性调成低。

功能：收件箱里收到邮件后，自动分析收件人（包括抄送的），找到第一个包含"@mycompany.com"的收件人，比如staff@mycompany.com。然后在收件箱里建一个以“staff@mycompany.com”命名的文件夹，把邮件移进去。

直接突出显示第一个收件人好像不太好办，只能通过这种方法来达到目的了

outlook2010稍作测试成功。

1. Private Function newFolder(ByVal folderName As String) As Outlook.Folder
   
2.     Dim myNameSpace As Outlook.NameSpace
   
3.     Dim myFolder As Outlook.Folder
   
4.    
   
5.     Set myNameSpace = Application.GetNamespace("MAPI")
   
6.     Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
   
7.     On Error Resume Next
   
8.     Set newFolder = myFolder.Folders.Add(folderName)
   
9.     Set newFolder = myFolder.Folders.Item(folderName)
   
10. 
    
11. End Function
    
12. 
    
13. 
    
14. Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    
15.     Dim varEntryIDs As Variant
    
16.     Dim myEntryID As Variant
    
17.     Dim myItem As MailItem
    
18.     Dim varRecpts As Recipients
    
19.     Dim myRecpt As Recipient
    
20.    
    
21.     Dim myAddr As String
    
22.     myAddr = ""
    
23.    
    
24.     Dim myCompanyEmail As String
    
25.    
    
26.     myCompanyEmail = "@myCompany.com" '设定贵公司邮箱的后缀，通过这个识别哪些邮件是发给贵公司的
    
27.    
    
28.     varEntryIDs = Split(EntryIDCollection, ",")
    
29.     For Each myEntryID In varEntryIDs
    
30.         Set myItem = Application.Session.GetItemFromID(myEntryID)
    
31.         Set varRecpts = myItem.Recipients
    
32.         For Each myRecpt In varRecpts
    
33.             If InStr(1, lcase(myRecpt.Address), lcase(myCompanyEmail)) > 0 Then
    
34.                 myAddr = myRecpt.Address
    
35.                 Exit For
    
36.             End If
    
37.         Next
    
38.         myItem.Move newFolder(myAddr)
    
39.     Next
    
40. 
    
41. End Sub
    

复制代码

neanderthal

谢谢老师, 待会试试看!!