使用 VBA 宏在 Outlook 中复制定期约会答案

【问题标题】：Copy recurring appointment in outlook with VBA macro使用 VBA 宏在 Outlook 中复制定期约会
【发布时间】：2015-09-28 14:19:33
【问题描述】：

如何使用 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

【问题讨论】：

它不会为我复制重复模式。而不是 cPatt = Item.GetRecurrencePattern 我希望之前有一个 Set 。我找不到 SetRecurrencePattern 的方法

标签： vba outlook

【解决方案1】：

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

【讨论】：

【解决方案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

【讨论】：