Outlook中删除重复邮件的宏

Long_III

在网上看到一个代码，但里面的Do...Loop执行只是检查了重复1次的情况，当存在多个邮件完全一样的时候，删除不干净，故修改了一下，初步运行正常。代码供参考：

先选中一个文件夹，然后运行代码

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

Long_III

这个功能挺好的，怎么都没人关注啊。。。外面都要用控件，麻烦，还是用代码实在

joezhu322

找了很久了，终于找到，谢谢

西东乐乐

非常好用。赞楼主

tjf_123

好东西，mark下

hryueyue

感谢分享，现在试试看

铁板卧虎

好东西，mark下

bluemidsummer

运行时在邮件数量比较多的文件夹无法运行，发生“运行时错误溢出6”字样，按调试，这一行代码标黄了For j = objItems.Count To 2 Step -1
请看看要如何修改，谢谢

LIQI1004ASDF

好东东，matk

ztccsj

谢谢分享，收藏先