Code ItemChange olayını kullanırken gereksiz yere çalışıyor

Question

"Günlüğü" işaretli/işaretliyse "günlük" takvimimde bir etkinlik oluşturmak için bu makroyu kullanıyorum. Benim sorunum, makro üç kez aynı olayı oluşturuyor.

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

Bir öğenin her değiştiğinde kodunuz çalışır. Kendi özel özelliğini (Item.UserProperties.Add/Item.Save) işlendiğinde işaretlemek için işaretleyin ve yeni bir öğe oluşturmadan önce bu özelliği (Item.UserProperties.Find) ve Item.IsMarkedAsTask = oIMarkToday denetimi ile kontrol edin.

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