Outlook返信時に返信元メールの分類項目を変更

Question

teratail初投稿となります。よろしくお願いします。

環境

Windows 10 64 bit
Office 365 Business
Outlook (調べたところバージョンは2001と表示されていますが、いわゆる最新バージョンのはずです）
IMAPメールアカウント

やりたいこと

ある人からメールを受信します（メールA）。
事前に作成していたルールによって、受信時にそのメールに「受信」という分類項目が付けられます（実現済み）。
その後、そのメールに対して返信を行います（メールB）。
メールBを送信した後、「その返信元メール」＝つまりメールAの分類項目から「受信」を削除して、「送信済」という分類項目を設定したいと考えています。

試したこと

上記の通り、受信時に「受信」という分類項目を設定することはできました。送信時に分類項目を設定するルールを作成してみましたが、メールBに対して分類項目を削除・追加することはできましたが、その送信元メールであるメールAに対しての操作ができませんでした。

質問内容

まず、そもそもルールによって上記のやりたいことは実現可能でしょうか。可能であれば簡単で良いのでその方法を教えてください。
不可能な場合、VBAの出番だと思います。

ThisOutlookSessionの所に、次のコードを書くと、メールの返信時（返信完了ではなくて、返信ボタンを押した瞬間）にスクリプトを実行できるようです。

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

End Sub

しかし、この中に何をどう書いたらよいのかがわかりません。
Item.ConversationID かと思ったのですが、空が返ってきました。

MSのサイトを見たのですが、どれもよくわかりません。
https://docs.microsoft.com/ja-jp/office/vba/api/outlook.mailitem

まとめ

そもそもルールで解決できればそれに越したことはありません。
VBAで実現する場合は送信時にマクロ実行するのかと考えていますが、具体的な方法（返信元メールのEntryIDや会話IDを取得して、その分類項目を変更する）がわからず困っています。

どうぞよろしくお願いします。

Answer 1

使えないか確認してください
FlagRequestを使用してＩＤ渡してます。
サブフォルダー（tes)でてすとしてます。

リボンのボタンには

Sub tes()

Dim ml As Variant
Dim ins As Inspector
Set ins = ActiveInspector
Dim A_Exp As Explorer

    If TypeName(ActiveWindow) = "Explorer" Then
        Set A_Exp = ActiveExplorer
        'DisplaySubject ActiveExplorer.Selection(1)
        If A_Exp.Selection.Count = 1 Then
            Set ml = A_Exp.Selection(1)
            'MsgBox ml.Subject
            Dim objOutlook As Outlook.Application
            Dim objMail As Outlook.MailItem
 
            Set objOutlook = New Outlook.Application
            Set objMail = objOutlook.CreateItem(olMailItem)
            With objMail
                '.To = ml.SenderName & "<" & ml.SenderEmailAddress & ">"      'メール宛先
                .To = ml.SenderEmailAddress         'メール宛先
                .Subject = "Re:" & ml.Subject       'メール件名
                .Body = "メール本文"                'メール本文
                .BodyFormat = olFormatPlain         'メールの形式
                .FlagRequest = ml.ConversationID
            End With
            objMail.Display

            Set objMail = Nothing
            Set objOutlook = Nothing
        End If
    
    End If

End Sub

送信押されたら、FlagRequestに保存したConversationIDを比較して判断しています

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

    Set InboxFolder = GetNamespace("MAPI").GetDefaultFolder(6) '受信トレイ
    Set subFolder = InboxFolder.Folders("tes") 'サブフォルダーの指定
    
    For Each InItms In subFolder.Items
     
        Select Case InItms.Class
        Case Is = 43 ' olMail
            InItemID = InItms.ConversationID
            ItemFlg = Item.FlagRequest
            If InItemID = ItemFlg Then
                MsgBox "マクロで作成された<" & InItms.Subject & ">の返信メール。"
                Item.FlagRequest = ""
            End If
        Case Is = 53 ' olMeetingRequest
        End Select
    Next
End Sub

Answer 2

私の環境ではテストできないのですが。

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    MsgBox item.Categories.Name 
    MsgBox item.Categories.CategoryID
End Sub

何が表示されるか試してください。

標準モジュールに記入できるなら
選択しているアイテムに対して確認できます。

Sub tes()

Dim ml As Variant
Dim ins As Inspector
Set ins = ActiveInspector
Dim A_Exp As Explorer

    If TypeName(ActiveWindow) = "Explorer" Then

        Set A_Exp = ActiveExplorer
        Set ml = A_Exp.Selection(1)
        MsgBox ml.Categories.Name
        MsgBox ml.Categories.CategoryID
    
    End If

End Sub

訂正します
CategoriesのなかのItemでした。
objCategory.Nameと objCategory.CategoryID

Sub tes2()

Dim ml As Variant
Dim ins As Inspector
Set ins = ActiveInspector
Dim A_Exp As Explorer
Dim objCategory As Category
 
    If TypeName(ActiveWindow) = "Explorer" Then

        Set A_Exp = ActiveExplorer
        Set ml = A_Exp.Selection(1)
        If A_Exp.Categories.Count > 0 Then
 
            ' Enumerate the Categories collection.
            For Each objCategory In A_Exp.Categories
 
            ' Add the name and ID of the Category object to
            ' the output string.
            strOutput = strOutput & objCategory.Name & _
                        ": " & objCategory.CategoryID & vbCrLf
            Next
        End If
        
    End If

End Sub

Comments

[wordsnwords]

新蔵さんありがとうございます。

まず、ThisOutlookSession内での次のコードですが、

MsgBox Item.Categories.Name
MsgBox Item.Categories.CategoryID

どちらの行も実行時に、「エラー424、オブジェクトが必要です」というエラーが表示されました。

また、標準モジュール内での次のコードも

MsgBox ml.Categories.Name
MsgBox ml.Categories.CategoryID

実行時に、「エラー424、オブジェクトが必要です」というエラーが表示されました。

これは私が独自にやっていたことですが、標準モジュール内に次のコードを書くと、選択中のメールの分類項目がわかります。

Sub test()

If Application.ActiveExplorer.Selection.Count = 1 Then '選択しているメッセージが1件のみの場合実行する

For Each objMsg In Application.ActiveExplorer.Selection

Debug.Print objMsg.Categories

Next
End If

End Sub

ただし、選択中のメッセージの場合です。今回のように、メールAに対する返信のメールBに分類項目を付ける、という方法ではありません。

IMAPアカウントでは、通常は分類項目が使えないようなのですが、マクロを書いてそれをリボンに登録することで無理矢理（？）使うことはできるようです。今回の用途で自動化は難しいとすると、選択中のメッセージに手動で分類を付けて管理するという方法に落ち着くのかもしれません。

[sinzou]

そのtest()に
　objMsg.Categoriesの値を変える（送信済みの色）
　objMsgの返信メールを作成し
　.Display
修正、手動送信
このマクロをリボンに登録し、返信するときはこのボタンをりようする
て手順は、、、だめかもしれませんが案です。

[wordsnwords]

新蔵さん、度々ありがとうございます。

tes2の方ですが「A_Exp.Categories」というものが存在しないようでエラーになります。If文の条件部分をカッコ（）で囲んで実行しています。

代替案は、完全自動ではないですができそうですね。

1. リボンに登録されたマクロボタンを押す
2. マクロ処理：元のメッセージに「返信済み」が設定される
3. マクロ処理：返信メールを作成して表示する
4. 手動処理：返信メールを書いて送信する

問題は、1の手順でボタンを押したはいいが、送信しなかった場合にも送信済みになってしまうところですね。
現時点では、リボンの所に「送信済」というマクロボタンを置いて、押す度にトグルするようにしました。

Sub toggleSent()
toggleCat ("送信済")
End Sub

Function toggleCat(Cat As String)

Dim objMsg As MailItem
Dim currentCat As String

If Application.ActiveExplorer.Selection.Count = 1 Then '選択しているメッセージが1件のみの場合実行する

For Each objMsg In Application.ActiveExplorer.Selection
currentCat = objMsg.Categories
'Debug.Print currentCat
If (InStr(currentCat, Cat) = 0) Then
objMsg.Categories = currentCat + ";" + Cat
Else
objMsg.Categories = Replace(currentCat, Cat, "")
End If
Next
End If

End Function

複数のメッセージを選択した状態だと、そのうちの1件にしか分類がオンオフできないので、上記のようにCount = 1で条件分岐しています。