OUTLOOK自动删除重复邮件脚本

OUTLOOK自动删除重复邮件脚本

Sub DeleteMail()
'outLook2007版本验证！使用前请调低宏安全性
    Dim olApp       As New Outlook.Application
    Dim fld_Inbox   As Outlook.Folder
    Dim objItems    As Outlook.Items
    Dim myItem      As Object
    Dim dupItem     As Object
    Dim i           As Long
    Dim ThisSenderEmailAddress, NextSenderEmailAddress As String
    Dim ThisSize, NextSize As Long
    Dim ThisSentOn, NextSentOn As Date
    Dim ThisBody, NextBody As String


    Set fld_Inbox = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    Set objItems = fld_Inbox.Items
    '按发信时间过滤邮件列表，
    'Set objItems = objItems.Restrict("[SentOn] > '8/1/2014'")

    objItems.Sort "[SentOn]", True
    Set myItem = objItems.GetFirst

    i = 0
    Do While TypeName(myItem) <> "Nothing"
        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.GetNext
            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
                Else
                    Set myItem = dupItem
                End If

            Else
                Set myItem = dupItem
            End If
        Else
           Set myItem = objItems.GetNext
        End If
    Loop
End Sub