【Outlook 自动删除重复邮件VBA脚本】分享给互联网技能从业者学习和参考。

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