从文件夹中删除重复的Outlook项目 [英] Remove duplicate Outlook items from a folder

问题描述

问题

1. 我将项目从在线存档移到pst文件时，Outlook 2016损坏了.
2. PST文件已恢复..但是许多项目(〜7000)重复了5次
3. 项目种类繁多，标准消息，会议要求等

我尝试了什么
我研究了现有的解决方案和工具，包括:

what I tried
I looked at existing solutions and tools, including:

1. 重复删除工具-除了一次可以删除10个项目的试用选项外，没有其他免费项目.
2. 各种代码解决方案，包括:
   Jacob Hilderbrand的努力从Excel运行的
   在Outlook中为宏以删除重复的电子邮件-

1. duplicate removal tools - none of which were free other than a trial option to remove 10 items at a time.
2. A variety of code solutions including:
   Jacob Hilderbrand's effort which runs from Excel
   Macro in Outlook to delete duplicate emails-

我决定走代码路线，因为它相对简单，并且可以更好地控制重复项的报告方式.

I decided to go the code route as it was relatively simple and to gain more control over how the duplicates were reported.

我将在下面发布我的自我解决方案，因为这可能会对他人有所帮助.

I will post my self solution below as it may help others.

我希望看到其他解决此问题的潜在方法(也许是powershell)，这可能比我的方法更好.

I would like to see other potential approaches (perhaps powershell) to fixing this problem which may be better than mine.

推荐答案

以下方法:

1. 为用户提供提示，以选择要处理的文件夹
2. 根据 Subject ， Sender ， CreationTime 和 Size
检查重复项
3. 将所有重复项移动(而不是删除)到正在处理的文件夹的子文件夹(已删除项目)中.
4. 创建CSV文件-存储在StrPath中的路径下，以创建对已移动电子邮件的Outlook的外部引用.

1. Provides users with a prompt to select the folder to process
2. Checks duplicates on the base of Subject, Sender, CreationTime and Size
3. Moved (rather than delete) any duplicates into a sub-folder (removed items) of the folder being processed.
4. Create a CSV file - stored under the path in StrPath to create a external reference to Outlook of the emails that have been moved.

已更新:检查大小时意外丢失了许多重复项，即使对于其他相同的邮件也是如此.我已将测试更改为subject和body

在Outlook 2016上测试

Const strPath = "c:\temp\deleted msg.csv"
Sub DeleteDuplicateEmails()

Dim lngCnt As Long
Dim objMail As Object
Dim objFSO As Object
Dim objTF As Object

Dim objDic As Object
Dim objItem As Object
Dim olApp As Outlook.Application
Dim olNS As NameSpace
Dim olFolder As Folder
Dim olFolder2 As Folder
Dim strCheck As String

Set objDic = CreateObject("scripting.dictionary")
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTF = objFSO.CreateTextFile(strPath)
objTF.WriteLine "Subject"

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.PickFolder

If olFolder Is Nothing Then Exit Sub

On Error Resume Next
Set olFolder2 = olFolder.Folders("removed items")
On Error GoTo 0

If olFolder2 Is Nothing Then Set olFolder2 = olFolder.Folders.Add("removed items")


For lngCnt = olFolder.Items.Count To 1 Step -1

Set objItem = olFolder.Items(lngCnt)

strCheck = objItem.Subject & "," & objItem.Body & ","
strCheck = Replace(strCheck, ", ", Chr(32))

    If objDic.Exists(strCheck) Then
       objItem.Move olFolder2
       objTF.WriteLine Replace(objItem.Subject, ", ", Chr(32))
    Else
        objDic.Add strCheck, True
    End If
Next

If objTF.Line > 2 Then
    MsgBox "duplicate items were removed to ""removed items""", vbCritical, "See " & strPath & " for details"
Else
    MsgBox "No duplicates found"
End If
End Sub

这篇关于从文件夹中删除重复的Outlook项目的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！