VBAを使用して受信メールにカテゴリを追加する

Question

Outlook 2003にVBAコードを書き込もうとしています。送信時にメールにカテゴリが追加されるため、カテゴリが自動的に追加された状態で応答が表示されます。これは、回答を簡単にするためです。

たとえば、全員に返信したメールを送信すると、受信トレイの返信が「〜返信」というカテゴリに自動的に表示されます。現在のところ、私は手動でそのように分類しています。

誰でもこのコードを支援できますか？私はこのフォーラムからカテゴリを削除する方法を見てきましたが、追加しようとしています。

Answer 1

共有受信トレイでこれをテストする方法はありませんが、次のように役立つことを願っています。以下のすべてのコードがThisOutlookSessionモジュール内に配置する必要があります

- Project 1 (VbaProject.OTM) 
    - Microsoft Office Outlook Objects 
    + ThisOutlookSession 
    + Forms 
    + Modules 

を取得するMicrosoft Office Outlook Objectsに対して+上

- Project 1 (VbaProject.OTM) 
    + Microsoft Office Outlook Objects 
    + Forms 
    + Modules 

クリック：

VBAエディタのエクスプローラでは、このような構造を一覧表示されます。

Outlookを開くと、最初のルーチン（Application_Startup）が呼び出されます。

Option Explicit 
Public UserName As String 
Public WithEvents MyNewItems As Outlook.Items 
Private Sub Application_Startup() 

    ' This event procedure is called when Outlook is started 

    Dim NS As NameSpace 

    Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI") 

    With NS 
    UserName = .CurrentUser 
    Set MyNewItems = NS.GetDefaultFolder(olFolderInbox).Items 
    End With 

    MsgBox "Welcome " & UserName 

End Sub 

上記のコードには2つの別個のアクティビティがあります。

まず、UserName = .CurrentUserと設定します。上記のコードを実行すると、UserNameが自分のユーザー名に設定されます。私は同じことがあなたとあなたの同僚にも当てはまると仮定しているので、下のマクロはどのユーザーが現在のユーザーであるかを知ることができます。ユーザーが.CurrentUserにアクセスするには、マクロのアクセス許可を与える必要があります。 InputBoxを使用してユーザーのイニシャルを取得することをお勧めします。

第2に、MyNewItemsを初期化します。これにより、受信トレイに追加される新しいアイテムのイベントハンドラを指定できます。

送信ボタンがクリックされた後、メッセージが送信される前に、次のルーチン（Application_ItemSend）が呼び出されます。メッセージを変更または追加することができます。 Cancel = Falseで送信をキャンセルすることもできます。

私はこのルーチンを使用して、おそらく有用なプロパティをイミディエイトウィンドウに出力しました。

私の実験によると、あなたが設定したカテゴリはすべて、送信済みアイテムのバージョンに記録されますが、受信者に送信されるバージョンには記録されません。したがって、相手がOutlookを使用していても返信には参加できません。

1つのオプションは、件名の末尾にコードを追加することです。別のオプションは、.ReplyRecipientsを別のアドレスに設定することです。メッセージは引き続きグループの受信トレイから送信されますが、返信は.ReplyRecipientsに送られます。

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

    ' This event procedure is called when the Send button is clicked but 
    ' before the item is sent. 

    Dim Inx As Long 

    Debug.Print "------Item Send" 

    ' Note this routine operate on all items not just mail items. 
    ' See "myNewItems_ItemAdd" for a method of restricting the 
    ' routine to mail items 

    With Item 

    .Subject = .Subject & " (xyz1)" 
    Debug.Print "Subject " & .Subject 

    For Inx = 1 To .Recipients.Count 
     Debug.Print "Recipient " & .Recipients(Inx).Name 
    Next 

    ' Remove any existing reply recipients 
    Do While .ReplyRecipients.Count > 0 
     .ReplyRecipients.Remove 1 
    Loop 

    .ReplyRecipients.Add "JohnSmith@Company.com" 

    End With 

End Sub 

最後のルーチン（myNewItems_ItemAdd）は、新しいメールアイテムを処理します。現在のコードは、会議出席依頼などの他の項目を処理しません。このコードは、イミディエイトウィンドウに件名を出力するだけです。ただし、メッセージを別のフォルダに移動することもできます。

Private Sub myNewItems_ItemAdd(ByVal Item As Object) 

    ' This event procedure is called whenever a new item is added to 
    ' to the InBox. 

    Dim NewMailItem As MailItem 

    Debug.Print "------Item Received" 

    On Error Resume Next 
    ' This will give an error and fail to set NewMailIten if 
    ' Item is not a MailItem. 
    Set NewMailItem = Item 
    On Error GoTo 0 

    If Not NewMailItem Is Nothing Then 
    ' This item is a mail item 
    With NewMailItem 
     Debug.Print .Subject 
    End With 
    Else 
    ' Probably a meeting request. 
    Debug.Print "Not mail item " & Item.Subject 
    End If 

End Sub 

希望すると、あなたにいくつかのアイデアが与えられます。