Outlook中删除重复邮件的宏

znjxxcxl

CSDN上看到闫辉_13510215218发的，也很有学习价值。

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

hanxing1983

稍微改进了以下代码