重複したメールを削除するマクロ


コメントにて以下のようなご要望をいただきました。


いつも参考にさせて頂いております。

メールの宛先で、自分宛て及び自分が参加しているメーリングリストが設定され、同じ内容のメールが2通届くケースが多く
困っています。以下のような、同一メールを検出し一方を削除するマクロをお願いできないでしょうか?

メーリングリスト宛のメールの件名には、”[メーリングリストの名称+通番]+本来のメール件名 となっているので、
  自分宛てのメールの件名を含むメーリングリストのメールを探すようなロジックで検索はできそうですが、
  受信トレイに大量のメールがあるため、他に高速に検出できるキー情報で検索できるとベストなのですが。

また、以前、同一メールを削除する(まったく同じメール)マクロが掲載されていたと記憶しているのですが、
こちらも使いたいと思っておりますので、掲載されておりましたらば、URLをお教え願います。


メーリングリスト サーバーからのメールと、直接送信されたメールを件名だけで判断するのは困難です。
というのも、たとえば、"[ML:100] Test" というメールの返信の件名はメーリングリストを経由するかどうかで以下のように変わります。

  メーリングリスト経由: [ML:101] RE: Test
  メーリングリストなし: RE: [ML:100] Test

これを同一と判断するというロジックを組むのは極めて難しいと思われます。
しかし、インターネット上のメールは Message-ID という文字列で一意性が保たれるよう規約で決まっており、Message-ID が同じメールは基本的には同じメールと判断しても良いはずです。
そのため、Message-ID をもとに重複するメールを判断し、先に受信したメールを削除するというマクロを作ってみました。
なお、再送すると Message-ID が重複するという事例があるので、Message-ID だけでなく本文もチェックしています。
ちなみに、重複メールではなく、重複した仕事や予定を削除するマクロであれば、こちらにあります。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub RemoveDuplicateMessages()
    Const PR_INTERNET_MESSAGE_ID = "http://schemas.microsoft.com/mapi/proptag/0x1035001E"
    Dim colItems As Items
    Dim i As Integer
    Dim j As Integer
    Dim strMsgID As String
    Set colItems = ActiveExplorer.CurrentFolder.Items
    colItems.Sort "[受信日時]", True
    For i = 1 To colItems.Count - 1
        strMsgID = colItems(i).PropertyAccessor.GetProperty(PR_INTERNET_MESSAGE_ID)
        For j = i + 1 To colItems.Count
            If colItems(j).PropertyAccessor.GetProperty(PR_INTERNET_MESSAGE_ID) = strMsgID Then
                If colItems(i).Body = colItems(j).Body Then
                    colItems(j).Delete
                End If
            End If
        Next
    Next
End Sub

マクロの登録方法やメニューへの追加について

広告

重複したメールを削除するマクロ」への4件のフィードバック

  1. ちょうど欲しかったマクロで大変ありがたいです。
    早速使用してみたのですが、インデックスが有効範囲外とのエラーが出るときがあります。
    Deleteされる対象メールがフォルダ末尾のメールだったときにそうなるような気がします。
    お手数ですがご確認いただけますでしょうか。使用環境はWin7+Outlook2010です。

  2. ずっと探していた機能なので非常に助かります。
    マクロを実行した際、一度の実行で1つの重複メールが削除されるのですが、
    フォルダー内のすべての重複メールをまとめて削除できないでしょうか。
    (Windows8+outlook2013です。)

  3. 私も本マクロを使用して、”インデックスが有効範囲外”のエラーが出ましたので調査して修正してみました。

    <エラー発生理由>
    本プログラムでは、ループ変数に i と j の2つを使っています。
    i は、比較元のアイテムを、j は比較対象のアイテムを参照するための配列番号として使用されています。
      今、仮に 11番目のアイテムと12番目のアイテムが重複していた場合、12番目のアイテムを削除します。
      削除後に処理が進むと、i がfor 分の中で+1 され12となり、12番目のアイテムを参照しようとしますが、
     既に削除されたアイテムを参照しようとするので、上記のエラーとなるのだと思います。

    <対処>
     重複アイテムを削除した際に、アイテムのリスト作成とリストの受信時刻のソート処理を、再度行うことで
     無効なアイテムへの参照が防げると思います。

     また、元のソースでは、重複アイテムを削除後も重複アイテムを探すロジックとなっていますが、
     重複メールが2通以上受信することはまずないと思われるため、処理の高速化のためには、
     削除対象となったアイテムと同一のアイテムを更に見つける処理をやめてしまうのが良いと思います。
     この2つの対処を行ったソースを以下に付けました。

     一応私の環境では、エラーができずに複数のメールを削除できましたが、上記のエラー発生原因や
     対処方法であっているでしょうか?

     なお、私はVBAの初心者のため、誤って大事なメールが削除されることも考えられますので、下記
     修正ソースをご利用される方は、ご自分の責任で使用してください。

    <修正ソース>
    ‘ 重複したメールを削除するマクロ
    Public Sub RemoveDuplicateMessages()
    Dim colItems As Items
    Dim i As Integer
    Dim j As Integer
    Dim strMsgID As String
    Set colItems = ActiveExplorer.CurrentFolder.Items
    colItems.Sort “[受信日時]”, True
    For i = 1 To colItems.Count – 1
    strMsgID = colItems(i).PropertyAccessor.GetProperty(PR_INTERNET_MESSAGE_ID)
    For j = i + 1 To colItems.Count
    If colItems(j).PropertyAccessor.GetProperty(PR_INTERNET_MESSAGE_ID) = strMsgID Then
    If colItems(i).Body = colItems(j).Body Then
    colItems(j).Delete
    ‘ アイテムを削除したので、再取得及び再ソート        ‘ エラー対処のため追加
    Set colItems = ActiveExplorer.CurrentFolder.Items   ‘ エラー対処のため追加
    colItems.Sort “[受信日時]”, True                ‘ エラー対処のため追加
             ‘ 高速化のため j のループを脱出
    Exit For                                ‘ 高速化のため追加
    End If
    End If
    Next
    Next
    End Sub

  4. 先程のソースで継続して重複チェックするようになったのは良かったのですが、
    2000アイテム程度のあるフォルダで実行したところ、いつになってもマクロが
    終了しないという問題が発生しました。
    VBAマクロを中断する方は、CTRL+PAUSE(又はBRAKE) なんですね。
    初めて知りました。

    対応方法を検討してみました。

    <理由>
     重複が見つからないと、1つのアイテムに全アイテムのチェックを行うことになるため
     全く重複がない場合、最もチェック回数が多くなってしまいます。

     上記の私の場合ですと、
      1番目のアイテムの場合、2000-1 の1999回チェック。
     2番目のアイテムの場合、1999-1 の1998回チェック。
       :
     といった具合です。

    <対処方法>
     アイテムのリストを一旦受信日でソートしていますので、重複アイテムは比較的
     近い範囲でリストに合わられるはずです。

     そこで、比較対象のアイテムが一定範囲以上離れたらば、その比較元のアイテムの
     チェック処理は終了し、次のアイテムのチェック処理に行くようにしてみました。

    但し、まれに複数メールが一時に大量に受信されることはあると思いますので、
     以下の場合、比較対象のアイテムの差を’5′ としています。

     私の2000アイテム程度あるフォルダの環境で実行して、1分もかからずに終了
     しましたが、この対処方法であっているでしょうか?

     なお、私はVBAの初心者のため、誤って大事なメールが削除されることも考えられますので、
     下記修正ソースをご利用される方は、ご自分の責任で使用してください。

    <修正ソース>
    ‘ 重複したメールを削除するマクロ
    Public Sub RemoveDuplicateMessages()
    Dim colItems As Items
    Dim i As Integer
    Dim j As Integer
    Dim strMsgID As String
    Set colItems = ActiveExplorer.CurrentFolder.Items
    colItems.Sort “[受信日時]”, True
    For i = 1 To colItems.Count – 1
    strMsgID = colItems(i).PropertyAccessor.GetProperty(PR_INTERNET_MESSAGE_ID)
    For j = i + 1 To colItems.Count
    If colItems(j).PropertyAccessor.GetProperty(PR_INTERNET_MESSAGE_ID) = strMsgID Then
    If colItems(i).Body = colItems(j).Body Then
    colItems(j).Delete
    ‘アイテムを削除したので、再取得及び再ソート       ’ エラー対処のため追加
    Set colItems = ActiveExplorer.CurrentFolder.Items ’ エラー対処のため追加
    colItems.Sort “[受信日時]”, True               ‘ エラー対処のため追加
    ‘ 高速化対応                            ‘ 高速化対応
    Exit For                              ’ 高速化対応
    End If
    End If
    ‘ 高速化対応                              ’ 高速化対応
    If (j > i + 5) Then                           ’ 高速化対応 一時点で同時に受信する可能性があるかにより、要調整
       Exit For                              ’ 高速化対応
    End If                                  ’ 高速化対応
    Next
    Next
    End Sub

コメントを残す

以下に詳細を記入するか、アイコンをクリックしてログインしてください。

WordPress.com ロゴ

WordPress.com アカウントを使ってコメントしています。 ログアウト / 変更 )

Twitter 画像

Twitter アカウントを使ってコメントしています。 ログアウト / 変更 )

Facebook の写真

Facebook アカウントを使ってコメントしています。 ログアウト / 変更 )

Google+ フォト

Google+ アカウントを使ってコメントしています。 ログアウト / 変更 )

%s と連携中