delete duplicate emails by marco

昨天又发现一个有趣的脚本，利用宏来删除outlook当中的重复邮件，这里记录一下。

事情的起因是有同事将office2016从64位换成32位，配置上没有任何变化，结果公司邮箱开始狂收历史邮件，高达数千封，搞不清是office傻了，还是公司邮件系统傻了。不过既然收取了，那就想办法删除重复邮件呗。先是想有没有任何插件，例如 outlook duplicate items remover 之类，结果都是收费，普通版本只能查询有多少重复，无法删除，然后再搜索了一番，发现了下面这段脚本。

打开outlook，按快捷键Alt+F11，建立工程，并复制宏。如图

脚本如下，代码来源再最下面做了注释，首先看到第一篇是中文版2018年发布的，但是2015和2016有老外已经发布了同样的脚本，中文版我粗略的看了下，是加了1句弹框提醒，共删除了多少封信，都有原创，故地址都保留了

Option Explicit
 
Sub DeleteDuplicateEmailsInSelectedFolder()
 
Dim i As Long
Dim n As Long
Dim DeletedCount As Long
Dim Message As String
Dim Items As Object
Dim AppOL As Object
Dim NS As Object
Dim Folder As Object
 
Set Items = CreateObject("Scripting.Dictionary")
 
'Initialize and instance of Outlook
Set AppOL = CreateObject("Outlook.Application")
 
'Get the MAPI Name Space
Set NS = AppOL.GetNamespace("MAPI")
 
'Allow the user to select a folder in Outlook
Set Folder = NS.PickFolder
 
'Get the count of the number of emails in the folder
n = Folder.Items.Count
 
'Set the initial deleted count
DeletedCount = 0
 
'Check each email starting from the last and working backwards to 1
'Loop backwards to ensure that the deleting of the emails does not interfere with subsequent items in the loop
For i = n To 1 Step -1
 
    On Error Resume Next
    'Load the matching criteria to a variable
    'This is setup to use the Sunject and Body, additional criteria could be added if desired
    Message = Folder.Items(i).Subject &amp; "|" &amp; Folder.Items(i).Body
 
        'Check a dictionary variable for a match
        If Items.Exists(Message) = True Then
        'If the item has previously been added then delete this duplicate
        Folder.Items(i).Delete
        DeletedCount = DeletedCount + 1
    Else
        'In the item has not been added then add it now so subsequent matches will be deleted
        Items.Add Message, True
End If
 
Next i
 
ExitSub:
 
'Release the object variables from memory
Set Folder = Nothing
Set NS = Nothing
Set AppOL = Nothing
 
MsgBox "共删除" &amp; DeletedCount &amp; "封邮件。"
 
End Sub

'  ---------------------
' 版权声明：本代码来自网络，中文版是18年的，应该是基于两个老外的15和16年的版本，加了1行统计提醒，这里都记录一下
' 原文链接：https://blog.csdn.net/uddiqpl/article/details/85045714
' https://stackoverflow.com/questions/30180728/macro-in-outlook-to-delete-duplicate-emails
' https://www.excelandaccess.com/delete-duplicate-emails-via-ms-excel-vba/