VBA宏：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:\TEMP\outlook.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

总结

今天讨厌写文档，就这样吧，千言万语尽在代码中。（有问题留言讨论）