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
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
我按照说明,将其加入 outlook 开发工具那里,全选邮件后点击运行,并无作用。而 excelhome 该帖子是没有回复的,不知该代码是否真的能用? 还请各位不吝赐教。谢谢。