Outlook でインターネットのメール スレッドを生成するマクロ


Outlook には [テーマ別] というビューがあり、これを使うとあるメールに対する返信が一つにまとまって表示されます。(このまとまりをメール スレッドと呼びます。)

しかし、インターネットのメーリング リストを使っている場合や件名を変更して返信したような場合に、Outlook Express などのように正しくメール スレッドを維持できないことがあります。

これは、Outlook が MAPI に則って開発されたメール アプリケーションであることが原因で発生しています。

MAPI はインターネット メールや特定メーカー独自のメッセージシステム、FAX などを統合的に扱うことができるというものであり、Outlook は MAPI のスレッド生成のインターフェースを使用してメールスレッドを生成します。ところが、MAPI はさまざまなメールシステムに対応するため、インターネット メール固有の事情は考慮しておらず、References や In-Reply-To といったインターネット のメールでスレッド生成に使用されるフィールドを使用しません。その結果、Outlook では [テーマ別] のビューを使ってもインターネット メールのメール スレッドが反映されないことになります。

しかし、実際にはほとんどの場合インターネットのメールしか使いませんので、Outlook でインターネット メールのメール スレッドを反映するためのマクロを作ってみました。

このマクロを使うには CDO 1.2.1 が必要になります。Outlook 2007 には CDO 1.2.1 が含まれないため、以下の URL から CDO 1.2.1 をダウンロードしてください。

http://www.microsoft.com/downloads/details.aspx?FamilyID=2714320d-c997-4de1-986f-24f081725d36&DisplayLang=en

マクロは以下の通りです。CreateThread を呼び出すことで現在表示しているフォルダのメールスレッドをインターネットの規約にあわせて生成します。

' マクロここから - ここをトリプルクリックするとマクロ全体を選択できます。
Const PR_TRANSPORT_MESSAGE_HEADERS = &H7D001E
Const PR_INTERNET_MESSAGE_ID = &H1035001E
Const PR_INTERNET_REFERENCES = &H1039001E
Const PR_IN_REPLY_TO_ID = &H1042001E
Const MAPI_E_NOT_FOUND = &H8004010F
'
Dim colCICache As Collection ' Conversation Index Cache
Dim colCTCache As Collection ' Conversation Topic Cache
'
Public Sub CreateThread()
    On Error Resume Next
    Dim objSession 'As MAPI.Session
    Dim strFolderId As String
    Dim objFolder 'As MAPI.Folder
    Dim objMsgFilt 'As MessageFilter
    Dim objMsgFilt2 'As MessageFilter
    Dim objItem 'As MAPI.Message
    Dim strMessageId As String
    Dim strReferences As String
    Dim strInReplyTo As String
    Dim strHeader As String
    Dim colMessages ' As Messages
'       
    Set objSession = CreateObject("MAPI.Session")
'    
    strFolderId = Application.ActiveExplorer.CurrentFolder.EntryID
    objSession.Logon "", "", False, False
    Set objFolder = objSession.GetFolder(strFolderId)
'    
    Set objMsgFilt = objFolder.Messages.Filter
    objMsgFilt.Type = "IPM.Note"
'    
    For Each objItem In objFolder.Messages
        strHeader = objItem.Fields(PR_TRANSPORT_MESSAGE_HEADERS).Value
        If Err.Number = MAPI_E_NOT_FOUND Then
            strHeader = ""
        ElseIf Err.Number <> 0 Then
            Exit Sub
        End If
        strMessageId = objItem.Fields(PR_INTERNET_MESSAGE_ID).Value
        If Err.Number = MAPI_E_NOT_FOUND Or strMessageId = "" Then
            objItem.Fields.Add PR_INTERNET_MESSAGE_ID, vbString, GetOneField("Message-ID:", strHeader)
            objItem.Fields.Add PR_INTERNET_REFERENCES, vbString, GetOneField("References:", strHeader)
            objItem.Fields.Add PR_IN_REPLY_TO_ID, vbString, GetOneField("In-Reply-To:", strHeader)
            objItem.Update
        End If
        DoEvents
    Next
'    
    Set colMessages = objFolder.Messages
    Set objMsgFilt2 = colMessages.Filter
    objMsgFilt2.Not = True
    objMsgFilt2.Fields.Add "CIFixed", vbBoolean, True
    Set colCICache = New Collection
    Set colCTCache = New Collection
'    
    For Each objItem In colMessages
        FixConversationIndex objItem, objFolder
        DoEvents
    Next
End Sub
'
Private Sub FixConversationIndex(objItem, objFolder)
    Dim strReferences As String
    Dim astrRefers() As String
    Dim i As Integer
    Dim objParent 'As MAPI.Message
    Dim strConversationIndex As String
    Dim strConversationTopic As String
    On Error Resume Next
'    
    strReferences = objItem.Fields(PR_INTERNET_REFERENCES).Value
    strReferences = strReferences & " " & objItem.Fields(PR_IN_REPLY_TO_ID).Value
'    
    If strReferences = " " Then
        Exit Sub
    End If
        
    astrRefers = Split(Trim(strReferences), " ")
    For i = UBound(astrRefers) To LBound(astrRefers) Step -1
        On Error Resume Next
        strConversationIndex = colCICache(astrRefers(i))
        strConversationTopic = colCTCache(astrRefers(i))
        On Error GoTo 0
        If strConversationIndex <> "" Then Exit For
'       
        For Each objParent In objFolder.Messages
            If objParent.Fields(PR_INTERNET_MESSAGE_ID).Value = astrRefers(i) Then
                FixConversationIndex objParent, objFolder
                strConversationIndex = objParent.ConversationIndex
                strConversationTopic = objParent.ConversationTopic
                Exit For
            End If
        Next
        DoEvents
    Next
    
    If strConversationIndex <> "" Then
        strConversationIndex = strConversationIndex _
            & Hex(objItem.TimeSent) & Format(objItem.TimeSent, "HHNNSS")
        objItem.ConversationIndex = strConversationIndex
        objItem.ConversationTopic = strConversationTopic
        objItem.Fields.Add "CIFixed", vbBoolean, True
'       
        objItem.Update
        colCICache.Add strConversationIndex, objItem.Fields(PR_INTERNET_MESSAGE_ID).Value
        colCTCache.Add strConversationTopic, objItem.Fields(PR_INTERNET_MESSAGE_ID).Value
    End If
End Sub
'
Public Function GetOneField(strName As String, strHeader As String)
    Dim ls As Long
    Dim c As String
    Dim strValue As String
    ls = InStr(1, vbCrLf & strHeader, vbCrLf & strName, vbTextCompare)
    If ls = 0 Then
        GetOneField = ""
        Exit Function
    End If
   
    strValue = Mid(strHeader, ls + Len(strName))
    ls = InStr(strValue, vbCrLf)
    While ls > 0
        Select Case Mid(strValue, ls + 2, 1)
            Case " ", vbTab
                ls = InStr(ls + 2, strValue, vbCrLf)
            Case Else
                strValue = Left(strValue, ls - 1)
                ls = 0
        End Select
    Wend
'   
    strValue = Replace(strValue, vbCrLf, "")
    strValue = Replace(strValue, vbTab, " ")
    While InStr(strValue, "  ") > 0
        strValue = Replace(strValue, "  ", " ")
    Wend
    GetOneField = Trim(strValue)
End Function

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

広告

Outlook でインターネットのメール スレッドを生成するマクロ」への19件のフィードバック

  1. とても便利なマクロです。しかし、大量メールがあると膨大な処理時間がかかり、その間outlookの利用ができません。そこで改善案ですが、マクロ処理中でもoutlookの利用が出来るようにならないでしょうか?または、マクロ処理を中断出来ないでしょう?または、閲覧しているメール画面でマクロ実行して、このメールに関連するもののみスレッド処理するようなことは出来ないでしょうか?

  2. To 茂さんループの中で DoEvents を実行するようにしてみました。これで、マクロ中でもある程度 Outlook の操作ができるようになるはずです。

  3. 早々の改善案ありがとうございます。マクロを入替えて実行して見ましたが、outlookが「応答なし」になるのは改善されました。しかし、outlookの操作が出来るようにはなりませんでした・・・。何か良い改善策はありませんか?

  4. To 茂さんOutlook の操作ができないとのことですが、閲覧ウィンドウの内容が変わらない、ということではありませんか?確かにマクロ実行中は閲覧ウィンドウの表示が変わりませんが、ダブルクリックでメッセージを開けば表示はできるはずです。

  5. DoEventsの数を増やしたら操作できるようになりました。ありがとうございました。あとは、処理完了数をステータスバーに表示するにはどうしたらよいでしょうか?

  6. To 茂さん残念ながら、現在の Outlook のバージョンでは、ステータスバーの表示をマクロで変更することはできません。

  7.  明けましておめでとうございます。ステータスバーの表示は出来ないんですね!残念です。色々とアドバイスありがとうございました。

  8. 閲覧ウィンドウの内容が変わらない状態を改善する方法はないものでしょうか?
    ダブルクリックでメッセージを開くか右クリックすると表示されるので、もう少し何かをすればできるような気もするのですが。

    • 申し訳ありませんが、上記の記事とご質問の関連が見えません。
      具体的にどのような操作をした場合に、閲覧ウィンドウの内容が変わらないという現象が発生するのかを教えていただけないでしょうか?

      • 受信トレイに大量のメールがある状態で本マクロを実行した時に閲覧ウィンドウの内容が変わらない現象が起きています。
        本マクロに限らず長時間のループ処理をさせると現象が起きます。
        閲覧ウィンドウの内容が変わらない現象は発生しています。
        試しに無限ループマクロを作成したところ
        Sub looptest()
        ‘終了させるときはctrl+break
        While 1
        DoEvents
        Wend

        End Sub
        ループ内にDoEventsを入れないとOUTLOOKが全く操作できなくなりDoEventsをいれOSに制御を逃がすようにすると
        OUTLOOKは操作できるようになりましたが閲覧ウィンドウの内容が変わらない現象は発生しています。
        ダブルクリックでメッセージを開くか右クリックすると表示されるので、もう少し何かをすればできるような気もします。
        何かご存じではありませんか?

      • 閲覧ウィンドウの表示はおそらくバックグラウンドの優先度の低いスレッドで実行されているのだと思います。
        そのため、マクロなどが実行されていると、いつまでも更新がされないのでしょう。
        残念ながら回避策はないと考えられます。

  9. Outlook2007で本マクロを利用させていただいています。
    とても便利で助かっていますが、気になっていることがあり、質問させてください。

    (1)
    既定のデータファイル(*.pst)以外の、新しく作ったpst内のフォルダで実行すると、
    Set objFolder = objSession.GetFolder(strFolderId)
    のところでNULLになってしまい、それ以降の本処理が実行されないのですが
    実行させる方法はありますでしょうか。

    (2)
    ある特定のフォルダで実行すると、無限ループになっているかのようにいつまで
    経ってもマクロが終了しません。メール数を20くらいまで減らすと正常に終了する
    ようになるのですが、そこからメールを1個増やしただけで終了しなくなります。
    他のフォルダではメールが数百個あっても正常に終了するのですが、
    そのフォルダだけそうなるのが不思議です。何か原因が考えられますでしょうか。

    (3)
    1回実行しただけではスレッドが繋がらず、何回か繰り返し実行するとようやく
    繋がることがよくあるのですが(例えば、1回実行すると4通のメールが2通ずつ
    2つのスレッドになり、もう1回実行すると4通が1つのスレッドに繋がる、等)
    1回の実行で済ませる方法はありませんか。

    • t-aizawaさんこんにちは、通りすがりの者です。
      (1)GetFolderで値が得られない件
      例えば個人用フォルダPersonalFolder.pstの置き場所を変えている場合、
      GetFolderメソッドの引数にStoreIDを加えると解決するかも知れません。
      strFolderStoreID = Application.ActiveExplorer.CurrentFolder.StoreID
      Set objFolder = objSession.GetFolder(strFolderId, strFolderStoreID)
      こちらでいかがでしょうか。

      (2)マクロが終わらない件
      わたしの推測ですが、何らかの理由でPR_INTERNET_MESSAGE_IDやPR_INTERNET_REFERENCES、
      PR_IN_REPLY_TO_IDのフィールド値が正しく入っておらず、
      FixConversationIndex Subプロシージャが呼ばれ続けているのではないでしょうか。
      objItem.Fields(PR_INTERNET_MESSAGE_ID).Value
      objItem.Fields(PR_INTERNET_REFERENCES).Value
      objItem.Fields(PR_IN_REPLY_TO_ID).Value
      これらの値を注視すると手がかりになるかも知れません。

      • n-sawakoさん、ありがとうございます。

        (1)については、ご指摘どおりStoreIDを追加したらうまくいきました。これは非常に嬉しいです。色々と捗ります。

        (2)については、ご指摘どおりFixConversationIndexからずっと返ってこないのは確認済みでしたが、もう少し
        動きを追ってみたところ、どうやら
        objItem.Fields.Add PR_INTERNET_MESSAGE_ID, vbString, GetOneField(“Message-ID:”,strHeader)
        からの3行でうまくフィールド値が取れていないようです(どのメールも”8″になってしまう)。
        よく判っていないのですが、http://msdn.microsoft.com/ja-jp/library/cc446716.aspx を見た感じだと
        Set objField = objFieldsColl.Add (PropTag, value) こちらの構文の方だと思うので、上記の2番目の
        引数(vbString,)は不要なのではないでしょうか。 変更したら一応うまくいったように見えます。

      • t-aizawaさん、こんにちは

        (1)について、無事に動作されたようで良かったです(^-^

        (2)について、おっしゃる通り構文記載ミスのようですね。
        このままではvbStringの定数”8″が各IDとして入ってしまい、
        FixConversationIndex内で再帰呼び出しされ続けて、おかしなことになっています。
        一旦IDに”8″が入ってしまったメールは、手動で修正しない限り更新されないので
        そのようなメールが1通でもあるフォルダでマクロを実行すると、ずっと処理されている
        ように感じるかも知れません。
        本文中のマクロも訂正される事を期待しています。

        (3)について、わたしもマクロを実行しつつ試行錯誤しています。
        どこかでobjFolder.MessagesをRefreshできたら変わるかも、と思っていましたが
        解決までは至っていません。最近は「数回実行するもの」とわりきってきました(笑)

  10. n-sawakoさん、こんばんは。

    (2)については、いったん”8″になったのは手動修正が必要なんだろうなと思い、
    If Err.Number = MAPI_E_NOT_FOUND Or strMessageId = “” Then
    の条件を外して、フォルダ内の全メールのMESSAGE-ID等を再設定する処理を
    1回実行しました。一応うまくいっているようです。

    (3)ですが、やはり私のとこだけではないのですね。
    私も「数回実行するもの」と割り切りつつあります。(^^;
    ただ、何回実行してもスレッドがくっつかないケースがあるのが不思議です。
    くっつけたいメール群だけ別の新規フォルダに移動してから実行するとちゃんと
    スレッドにくっつくので、MESSAGE-ID等が変な訳ではないと思うのですが…。
    まぁ別フォルダ移動で回避するのですが、一手かかるのがちょっと残念。

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中