outlook收件箱中发件人使用联系人

outlook有个特别不符合国人习惯的小问题：即使发件人已经添加到了联系人地址簿中，在收件箱中查看邮件列表时，发件人栏显示的依然是对方自定义的名字，整体看起来很杂乱。
百般查找也没找到设置方法和合适的插件。写了个宏脚本，暂时实现了替换收件箱中邮件列表发件人的功能。
最近工作忙，先凑合用着，以后有时间再完善人机交互方案。

使用方法
在outlook选项中使能开发工具页面，打开VB编辑开发窗口。添加新的模块，在模块的编辑界面贴入下面的代码。运行宏即可。

详细代码
代码中的write #1等是注释代码，可以都删掉。

函数1
函数updatesendername输入为收件箱中的没封邮件，函数功能是判断发件人类型是否是exchange，如果是，则可以获取到exchange通讯录中的信息，使用信息替换发件人名称（exchange通讯录类中的可用字段可以参考outlook vb的帮助文档）
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application

Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"

Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"

Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select

Set objApp = Nothing
End Function
Function mail_rename_sender(ByVal Item As Object, ByVal log As Boolean)

Dim myItem As Outlook.MailItem
Dim tmpPos As Integer
Dim tmpFlag As String
Set myItem = Item

If log Then
Write #1, '写入空白行。
Write #1, myItem.SenderEmailAddress, myItem.SentOnBehalfOfName, myItem.SenderEmailType, myItem.SenderName, myItem.SendUsingAccount, TypeName(myItem.sender)
End If

If myItem.SenderEmailType = "EX" Then
Dim oExUser As Outlook.ExchangeUser
Set oExUser = myItem.sender.GetExchangeUser
If log Then
Write #1, "11111", oExUser.Address, oExUser.PrimarySmtpAddress, oExUser.FirstName, oExUser.LastName, oExUser.Name
End If

If InStr(oExUser.OfficeLocation, "未来") <> 0 Then
tmpFlag = "$"
tmpPos = 10
Else
tmpPos = InStr(oExUser.OfficeLocation, "（")
'MsgBox (tmpPos)
If tmpPos = 0 Then
tmpPos = 11
Else
tmpPos = tmpPos - 1
End If
tmpFlag = "*"
End If
myItem.SentOnBehalfOfName = tmpFlag & " " & oExUser.LastName & "(" & oExUser.Alias & ")@" & "[" & Left(oExUser.OfficeLocation, tmpPos) & "]" '"-" & oExUser.CompanyName & "]"

Else
If TypeName(myItem.sender) = "AddressEntry" Then '发件人在联系人中
Set itemContact_temp = myItem.sender.GetContact()
If itemContact_temp Is Nothing Then
If log Then
Write #1, "77777777777777777777", myItem.Subject
End If
Else
If log Then
Write #1, "2222222", itemContact_temp.Email1Address
End If
myItem.SentOnBehalfOfName = "# " & itemContact_temp.FullName
End If
Else 'sender类型不是addressEntry时，意味着联系人中没有保存该发件人
Write #1, "666666666666", TypeName(myItem.sender)
End If
End If

myItem.Save

End Function

Sub mail_rename_sender_batch(ByVal num As Integer)

Dim oInbox As Outlook.Folder
Dim myItem As Outlook.MailItem
Dim myItems As Outlook.Items
Dim tmpCount As Integer

Open "G:TEMPoutlook.txt" For Output As #1
Write #1, "Hello World", 234 ' 写入以逗号隔开的数据。
Write #1, '写入空白行。

Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox)

Set myItems = oInbox.Items
myItems.Sort "[SentOn]", True

tmpCount = myItems.Count
If (num > 0) And (num < tmpCount) Then
tmpCount = num
End If

'遍历所有邮件
For i = 1 To tmpCount 'oInbox.Items.Count

'If TypeName(oInbox.Items(i)) = "MailItem" Then

'Set myItem = oInbox.Items(i)
If TypeName(myItems(i)) = "MailItem" Then

Set myItem = myItems(i)

temp = mail_rename_sender(myItem, True)

End If

Next

Close #1 ' 关闭文件。

End Sub

函数2
update_folder是宏名（第一次折腾office中的vb，没搞懂概念，感觉sub xxx类似main函数，算是程序的主入口）点击运行宏就会从这里开始，函数中内容是获取到收件箱，并遍历收件箱中所有电子邮件（还有些会议通知神马的先不管），每封邮件调用updatesendername函数更新发件人名称。

Sub update_folder()
Dim myc As common
Set myc = New common
myc.mail_rename_sender_batch (-1)

End Sub

Private Sub Application_BeforeFolderSharingDialog(ByVal FolderToShare As MAPIFolder, Cancel As Boolean)

End Sub

Private Sub Application_ItemLoad(ByVal Item As Object)
Dim myc As common
Set myc = New common
Set myObj = myc.GetCurrentItem()
If TypeName(myObj) = "MailItem" Then
temp = myc.mail_rename_sender(myObj, False)
End If
End Sub

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
End Sub

Private Sub Application_MAPILogonComplete()

End Sub

Private Sub Application_NewMail()

'Dim myc As common
'Set myc = New common
'myc.mail_rename_sender_batch (3)

End Sub
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim myc As common
Set myc = New common
Dim vMail As Object
Set vMail = Application.Session.GetItemFromID(EntryIDCollection)
'MsgBox vMail.To & vbCrLf & vMail.CC & TypeName(vMail)

If TypeName(vMail) = "MailItem" Then
temp = myc.mail_rename_sender(vMail, False)
End If

End Sub

outlook收件箱中发件人使用联系人的下载地址：

本地下载