Question

如何使用VBA复制Outlook 2013中的定期约会？我已经尝试将RecurrencePattern对象从源项目复制到目标项目（cAppt），但是这会将开始日期设置为下一个直接日历间隔（例如，如果现在是4:12，则定期系列将设置为从今天4:30）而不是原始项目的实际开始日期。关于如何做到这一点的任何提示？

Private Sub curCal_ItemAdd(ByVal Item As Object)
Dim cAppt As AppointmentItem
Dim oPatt As RecurrencePattern
Dim cPatt As RecurrencePattern
Dim moveCal As AppointmentItem

' On Error Resume Next

'only copy items not marked as private
If Item.Sensitivity <> olPrivate Then

   Item.Body = Item.Body & "[" & GetGUID & "]"
   Item.Save

Set cAppt = Application.CreateItem(olAppointmentItem)
If Item.IsRecurring Then
    Set cPatt = cAppt.GetRecurrencePattern
    cPatt = Item.GetRecurrencePattern
End If

With cAppt
    .Subject = Item.Subject
    .Start = Item.Start
    .Duration = Item.Duration
    .Location = Item.Location
    .Body = Item.Body
End With

' set the category after it's moved to force EAS to sync changes
 Set moveCal = cAppt.Move(newCalFolder)
 moveCal.Categories = "moved"
 moveCal.Save

End If
End Sub

Answer 1

尝试使用AppointmentItem.Copy而不是Application.CreateItem。

Answer 2

我知道这是一篇很老的帖子，但我想分享我的发现，为什么 OP 的原始 VBScript 不起作用。

AppointmentItem.Copy 可以工作，但根据它的使用时间，它可能会导致 VBScript 中断（例如，将约会添加到您的个人时自动将其复制到共享日历）。 Application.CreateItem 没有这个缺点。

经过一些测试，我可以确认（无论如何在 Outlook 2016 中）GetRecurrencePattern 方法捕获所有相关属性除了 StartTime 属性。因此，开始时间被设置为日历中下一个即时时间范围的默认值。

要解决此问题，您可以按如下方式更改脚本：

Private Sub curCal_ItemAdd(ByVal Item As Object)
Dim cAppt As AppointmentItem
'Dim oPatt As RecurrencePattern --unnecessary declaration, can delete.
Dim cPatt As RecurrencePattern
Dim moveCal As AppointmentItem

' On Error Resume Next

'only copy items not marked as private
If Item.Sensitivity <> olPrivate Then

   Item.Body = Item.Body & "[" & GetGUID & "]"
   Item.Save

Set cAppt = Application.CreateItem(olAppointmentItem)
If Item.IsRecurring Then
    Set cPatt = cAppt.GetRecurrencePattern
    cPatt = Item.GetRecurrencePattern
    cPatt.StartTime = Item.Start 'Add appointment time as StartTime.
    cPatt.Duration = Item.Duration 'need to define Duration (or EndTime) after changing StartTime.
End If

With cAppt
    .Subject = Item.Subject
    .Start = Item.Start
    .Duration = Item.Duration
    .Location = Item.Location
    .Body = Item.Body
End With

' set the category after it's moved to force EAS to sync changes
 Set moveCal = cAppt.Move(newCalFolder)
 moveCal.Categories = "moved"
 moveCal.Save

End If
End Sub

另外，不确定 OP 是否需要给予信用，但信用应归功于代码主要是来自 http://www.slipstick.com/developer/copy-new-appointments-to-another-calendar-using-vba/ 的 copypasta

使用VBA宏复制Outlook中的定期约会

2 个答案: