未返信のメールを別のフォルダーに移動するマクロ のコメントにて以下のご要望をいただきました。
はじめまして。Outlookで相手のメールに返信した時に返信した元のメールを自動でアーカイブするマクロを作りたいのですが、同じように以下のプロパティをチェックすれば作成可能でしょうか？
PR_ICON_INDEX (メッセージ一覧で表示するアイコンの指定) が 261 (返信アイコン) に変わる
PR_LAST_VERB_EXECUTED (メッセージに対して最後に実行された処理) が 102 (差出人に返信) または 103 (全員に返信) に変わる
当方、送信済みメールも受信ボックスにコピーされるように設定しており、受信ボックスの中を「送信済みメールのコピー=返信待ちメールもしくは自分のメールで終わったメール」「受信メール(未返信)=要返信もしくは相手のメールで終わったメール」のみにするのが目的です。
自分が返信したメールを受信ボックスにコピーするので、返信元のメールはアーカイブに送りたいと考えております。ご助言いただけると助かります。
自分が返信したメールを確認するのであれば PR_ICON_INDEX などでも確認はできますが、これだけだと相手が返信してきたメールが判断できず、「送信済みメールのコピー=返信待ちメールもしくは自分のメールで終わったメール」が実現できないと思われます。
Outlook オブジェクト モデルでは、Conversation オブジェクトを使用してメールのスレッドのツリーを確認できるので、件名が RE: で始まるメールの親 (返信元) のメールをアーカイブに移動するという処理を行えば、ご要望は満たせると思います。
マクロは以下の様になります。
Public Sub ArchiveOldItemInThreads()
Dim fldInbox As Folder
Dim fldArchive As Folder
Dim colItems As Items
Dim objConv As Conversation
Dim curItem As Object
Dim prevItem As Object
Dim i As Integer
' 受信トレイの取得
Set fldInbox = Session.GetDefaultFolder(olFolderInbox)
' アーカイブ フォルダーの取得
Set fldArchive = fldInbox.Parent.Folders("アーカイブ")
' 受信トレイのアイテムを受信日時の降順で並び替え
Set colItems = fldInbox.Items
colItems.Sort "ReceivedTime", True
' アイテムを一つずつチェック
For i = fldInbox.Items.Count To 1 Step -1
Set curItem = fldInbox.Items(i)
' 件名が RE: で始まる場合はスレッドのチェック
If UCase(curItem.Subject) Like "RE:*" Then
' Conversation オブジェクトを取得
Set objConv = curItem.GetConversation()
' Conversation より返信元のメールを取得
Set prevItem = objConv.GetParent(curItem)
' 返信元メールが見つかったら
If Not prevItem Is Nothing Then
' 既にアーカイブ フォルダーに移動されていなければ
If prevItem.Parent <> fldArchive Then
' アーカイブ フォルダーに移動
prevItem.Move fldArchive
End If
End If
End If
Next
End Sub
Outlook 研究所 