VBA宏:outlook收件箱中发件人使用联系人

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

总结

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

评论 1 您还未登录,请先 登录 后发表或查看评论

“相关推荐”对你有帮助么?

  • 非常没帮助
  • 没帮助
  • 一般
  • 有帮助
  • 非常有帮助
提交
©️2022 CSDN 皮肤主题:游动-白 设计师:我叫白小胖 返回首页

打赏作者

wlwdhr

你的鼓励将是我创作的最大动力

¥2 ¥4 ¥6 ¥10 ¥20
输入1-500的整数
余额支付 (余额:-- )
扫码支付
扫码支付:¥2
获取中
扫码支付

您的余额不足,请更换扫码支付或充值

打赏作者

实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、C币套餐、付费专栏及课程。

余额充值