我们的征途是星辰大海

My Conquest Is the Sea of Stars

delete duplicate emails by marco

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

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

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

《delete duplicate emails by marco》

脚本如下,代码来源再最下面做了注释,首先看到第一篇是中文版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 & "|" & 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 "共删除" & DeletedCount & "封邮件。"
 
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/

F5执行这个宏,会让你选择某个文件夹

《delete duplicate emails by marco》

此时outlook和脚本都卡住假死几分钟,然后反馈执行结果,共删除了多少封信,

《delete duplicate emails by marco》

这里还有一个问题,删除的是已读的历史邮件,保留的是新收下来的邮件:),需要手动再标记一下 全部已读。

点赞

发表评论

电子邮件地址不会被公开。 必填项已用*标注

此站点使用Akismet来减少垃圾评论。了解我们如何处理您的评论数据