Outlook中的宏删除重复的电子邮件-

Question

Public Sub RemDups()

Dim t As Items, _
    i As Integer, _
    arr As Collection, _
    f As Folder, _
    parent As Folder, _
    target As Folder, _
    miLast As MailItem, _
    mi As MailItem

Set parent = Application.GetNamespace("MAPI").PickFolder
Set target = Application.GetNamespace("MAPI").PickFolder


For Each f In parent.Folders
    Set t = f.Items
    t.Sort "[Subject]"
    i = 1
    Set miLast = t(i)
    Set arr = New Collection
    While i < t.Count
        i = i + 1
        If TypeName(t(i)) = "MailItem" Then
            Set mi = t(i)
            If miLast.Subject = mi.Subject And miLast.Body = mi.Body _
            And miLast.ReceivedTime = mi.ReceivedTime Then
                arr.Add mi
            Else
                Set miLast = mi
            End If
        End If
    Wend
    For Each mi In arr
        mi.Move target
    Next mi
Next f

End Sub

设置 miLast = t(i) 给出“运行时错误'440' 数组索引超出范围 请帮忙

Answer 1

这是基于网络创建的修改版本（Blog ExcelandAccess）

这段代码让我们选择一个文件夹来搜索和删除重复的项目。

Option Explicit

'Set a reference to the Microsoft Scripting Runtime from Tools, References.

Sub DeleteDuplicateEmailsInSelectedFolder()

Dim i As Long
Dim n 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

'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
    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

End Sub

更好的版本是在其他文件夹中以递归方式查找重复的电子邮件。