请教 outlook2016 去除重复邮件的方法

[swlaw]

各位先进你们好。
近期为公司领导设置了 outlook2016 收发公司自己建的邮箱，设置成 POP3。现在一台 PC 要重装，备份了 PST。重装完成，打开该 PST，并重新设置 outlook。邮箱不断收取重复的邮件（备份的 PST 有一份，再次收取一次）。

由于邮件很多，超过 3000 份，要逐一排除很困难。网上查找了很多资料，包括微软的官方技术论坛，都简单地建议下载“ outlook-duplicates-remover ”使用。可改软件需要注册，较旧的版本对中文支持也不好，邮件标题乱码。

在多次查找有，在 EXCELHOME 论坛查到以下 VB 代码：



Sub DelDuplicateMail() '删除重复邮件
Dim olApp As Outlook.Application
Dim fld_Inbox As Outlook.Folder
Dim objItems As Outlook.Items
Dim myItem As Object
Dim dupItem As Object
Dim i%, j%
Dim ThisSenderEmailAddress, NextSenderEmailAddress As String
Dim ThisSize, NextSize As Long
Dim ThisSentOn, NextSentOn As Date
Dim ThisBody, NextBody As String
Dim st As Object

aa = Timer
Set olApp = Outlook.Application

For Each st In Application.ActiveExplorer.Selection '选择当前邮件对应的文件夹
If TypeName(st) = "MailItem" Then
Set fld_Inbox = st.Parent
Exit For
End If
Next

If TypeName(fld_Inbox) <> "MAPIFolder" Then MsgBox "请选择有效文件夹，程序退出": Exit Sub
Set objItems = fld_Inbox.Items
If objItems.Count = 1 Then MsgBox "请选择大于 1 封邮件的文件夹，程序退出": Exit Sub

'Set objItems = objItems.Restrict("[SentOn] > '8/1/2014'"
objItems.Sort "[SentOn]", True '按日期排序

i = 0
For j = objItems.Count To 2 Step -1
Set myItem = objItems(j)
If TypeName(myItem) = "MailItem" Then
ThisSenderEmailAddress = myItem.SenderEmailAddress '发件人邮箱
ThisSize = myItem.Size '邮件大小
ThisSentOn = myItem.SentOn '发信时间,如"2015/8/28 9:57:02"
ThisBody = myItem.Body '邮件文本内容

Set dupItem = objItems(j - 1)
If TypeName(dupItem) = "MailItem" Then
NextSenderEmailAddress = dupItem.SenderEmailAddress
NextSize = dupItem.Size
NextSentOn = dupItem.SentOn
NextBody = dupItem.Body

'删除发件人、发信时间和邮件内容完全相同的邮件
If ThisSenderEmailAddress = NextSenderEmailAddress And ThisSentOn = NextSentOn And ThisBody = NextBody Then
dupItem.Delete
i = i + 1
End If
End If
End If
Next

MsgBox "共删除" & i & "封邮件。运行时间为" & Format(Timer - aa, "0.00") & "秒"
End Sub

我按照说明，将其加入 outlook 开发工具那里，全选邮件后点击运行，并无作用。而 excelhome 该帖子是没有回复的，不知该代码是否真的能用？
还请各位不吝赐教。谢谢。

[intuitionfly]

可以用。我用的 outlook 2010，把宏设置成一个按钮，选中收件箱中任意一个邮件，运行宏就行了。