7

問題

  1. アイテムをオンライン アーカイブから pst ファイルに移動しているときに、Outlook 2016 が破損しました。
  2. PST ファイルは復元されました ....しかし、多くのアイテム (~7000) が 5 回複製されています
  3. さまざまなアイテム タイプ、標準メッセージ、会議出席依頼などがあります。

私が試した
こと 次のような 既存のソリューションとツールを調べました。

  1. 重複削除ツール- 一度に 10 個のアイテムを削除する試用オプション以外は無料ではありませんでした。
  2. 以下を含むさまざまなコード ソリューション:重複したメールを削除するために OutlookのExcel マクロから実行される
    Jacob Hilderbrand の取り組み-

コードルートは比較的単純で、重複の報告方法をより詳細に制御できるため、コードルートを使用することにしました。

他の人に役立つかもしれないので、以下に私の自己解決策を投稿します。

この問題を修正するための他の潜在的なアプローチ（おそらくpowershell）を見たいと思います。

4

4 に答える 4

14

以下のアプローチ：

  1. 処理するフォルダを選択するプロンプトをユーザーに提供します
  2. Subject、Sender、CreationTime、およびSizeに基づいて重複をチェックします
  3. 処理中のフォルダーのサブフォルダー (削除されたアイテム) に重複を (削除するのではなく) 移動しました。
  4. CSV ファイルを作成します - のパスの下に保存され、StrPath移動された電子メールの Outlook への外部参照を作成します。

更新: サイズをチェックすると、驚くべきことに、他の点では同一のメール アイテムであっても、多数の重複を見逃していました。テストをsubjectandに変更しました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
于 2016-01-08T03:47:23.147 に答える
1

メールの並べ替えを利用して、重複をより効率的にチェックするスクリプトを次に示します。

電子メールを決定論的な順序 (受信日など) で処理している場合、見たすべての電子メールの巨大な辞書を維持する必要はありません。日付が変わると、以前の日付の別の電子メールが表示されることはないことがわかっているため、重複することはないため、日付が変わるたびに辞書をクリアできます。

このスクリプトでは、完全なメッセージ定義に HTMLBody を使用する項目もあれば、そのプロパティを持たない項目もあるという事実も考慮されています。

Sub DeleteDuplicateEmails()
    Dim allMails As Outlook.Items
    Dim objMail As Object, objDic As Object, objLastMail As Object
    Dim olFolder As Folder, olDuplicatesFolder As Folder
    Dim strCheck As String
    Dim received As Date, lastReceived As Date        

    Set objDic = CreateObject("scripting.dictionary")
    With Outlook.Application.GetNamespace("MAPI")
        Set olFolder = .PickFolder
    End With
    If olFolder Is Nothing Then Exit Sub

    On Error Resume Next
    Set olDuplicatesFolder = olFolder.Folders("Duplicates")
    On Error GoTo 0
    If olDuplicatesFolder Is Nothing Then Set olDuplicatesFolder = olFolder.Folders.Add("Duplicates")

    Debug.Print "Sorting " & olFolder.Name & " by ReceivedTime..."
    Set allMails = olFolder.Items
    allMails.Sort "[ReceivedTime]", True
    Dim totalCount As Long, index As Long
    totalCount = allMails.count
    Debug.Print totalCount & " Items to Process..."

    lastReceived = "1/1/1987"
    For index = totalCount - 1 To 1 Step -1
        Set objMail = allMails(index)
        received = objMail.ReceivedTime
        If received < lastReceived Then
            Debug.Print "Error: Expected emails to be in order of date recieved. Previous mail was " & lastReceived _
                & " current is " & received
            Exit Sub
        ElseIf received = lastReceived Then
            ' Might be a duplicate track mail contents until this recieved time changes.
            ' Add the last mail to the dictionary if it hasn't been tracked yet
            If Not objLastMail Is Nothing Then
                Debug.Print "Found multiple emais recieved at " & lastReceived & ", checking for duplicates..."
                objDic.Add GetMailKey(objLastMail), True
            End If
            ' Now check the current mail item to see if it's a duplicate
            strCheck = GetMailKey(objMail)
            If objDic.Exists(strCheck) Then
                Debug.Print "Found Duplicate: """ & objMail.Subject & " on " & lastReceived
                objMail.Move olDuplicatesFolder
                DoEvents
            Else
                objDic.Add strCheck, True
            End If
            ' No need to track the last mail, since we have it in the dictionary
            Set objLastMail = Nothing
        Else
            ' This can't be a duplicate, it has a different date, reset our dictionary
            objDic.RemoveAll
            lastReceived = received
            ' Keep track of this mail in case we end up needing to build a dictionary
            Set objLastMail = objMail
        End If

        ' Progress update
        If index Mod 10 = 0 Then
            Debug.Print index & " Remaining..."
        End If
        DoEvents
    Next
    Debug.Print "Finished moving Duplicate Emails"
End Sub

そして、メールを「一意に識別する」ために上記で参照したヘルパー関数。必要に応じて調整しますが、被写体と全身が同じなら他をチェックしても意味がないと思います。カレンダーの招待状などにも使用できます:

Function GetMailKey(ByRef objMail As Object) As String
    On Error GoTo NoHTML
    GetMailKey = objMail.Subject & objMail.HTMLBody
    Exit Function
BodyKey:
    On Error GoTo 0
    GetMailKey = objMail.Subject & objMail.Body
    Exit Function
NoHTML:
    Err.Clear
    Resume BodyKey
End Function
于 2018-07-06T17:12:13.973 に答える