宏在Outlook中刪除重複emails-

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（1）給出了「運行時error'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 

更好的版本是在遞歸模式下在其他文件夾中查找重複的電子郵件。