ItemChangeイベントを使用しているときにコードが不必要に実行される

Question

「今日」のマークが付いている場合は、このマクロを使用して電子メールから「ログ」カレンダーにイベントを作成します。私の問題は、マクロが同じイベントを3回作成していることです。

Public WithEvents OlItems As Outlook.Items 

Public Sub Initialize_handler() 
    Set OlItems = Application.GetNamespace("MAPI"). _ 
     GetDefaultFolder(olFolderInbox).Items 
End Sub 

Private Sub OlItems_ItemChange(ByVal Item As Object) 

Dim Ns As Outlook.NameSpace 
Dim objApp As Outlook.Application 
Dim olAppt As Outlook.AppointmentItem 


If Item.IsMarkedAsTask = oIMarkToday Then 

Set Ns = Application.GetNamespace("MAPI") 
Set objApp = Application 


    ' Subfolder named 'Log' under calendar 
Set calFolder = Ns.GetDefaultFolder(olFolderCalendar).Folders("Log") 
Set olAppt = calFolder.Items.Add(olAppointmentItem) 
With olAppt 
     .Subject = Item.Subject 
     '.Attachments.Add Item 
     .Body = Item.Body 
     .Start = Now + 2 
     .End = Now + 2.08 
     .ReminderSet = False 
     .BusyStatus = olFree 
     .Save 
     '.Display 'show to add notes 
End With 
Set objApp = Nothing 
Set Ns = Nothing 

End If 

End Sub 

Answer 1

アイテムが変更されるたびにコードが実行されます。独自のカスタムプロパティ（Item.UserProperties.Add/Item.Save）を処理済みとしてマークし、そのプロパティ（Item.UserProperties.Find）とItem.IsMarkedAsTask = oIMarkTodayチェックを確認してから、新しい項目を作成してください。

Private Sub OlItems_ItemChange(ByVal Item As Object) 

Dim Ns As Outlook.NameSpace 
Dim objApp As Outlook.Application 
Dim olAppt As Outlook.AppointmentItem 
Dim objProp As Outlook.UserProperty 

set objProp = Item.UserProperties.Find("ProcessedByMe") 

If (Item.IsMarkedAsTask) And (objProp Is Nothing) Then 

    'mark the original item as processed 
    set objProp = Item.UserProperties.Add("ProcessedByMe", olYesNo) 
    objProp.Value = true 
    Item.Savwe 

    Set Ns = Application.GetNamespace("MAPI") 
    Set objApp = Application 

    ' Subfolder named 'Log' under calendar 
    Set calFolder = Ns.GetDefaultFolder(olFolderCalendar).Folders("Log") 
    Set olAppt = calFolder.Items.Add(olAppointmentItem) 
    With olAppt 
     .Subject = Item.Subject 
     '.Attachments.Add Item 
     .Body = Item.Body 
     .Start = Now + 2 
     .End = Now + 2.08 
     .ReminderSet = False 
     .BusyStatus = olFree 
     .Save 
     '.Display 'show to add notes 
    End With 
    Set objApp = Nothing 
    Set Ns = Nothing 

End If 

End Sub