使用“olFullDetails”或“olFreeBusyAndSubject”导出包含定期会议的 Outlook 日历

Question

我创建了 VBA 代码，将 Outlook 日历从我的工作帐户发送到我的私人邮件，以将约会导入到我的私人日历。

仅导出定期约会的第一个约会。

如果我使用以下命令，所有约会都会导出：

CalendarDetail = olFreeBusyOnly

有没有办法使用

olFreeBusyAndSubject

或

olFullDetails

导出所有约会（包括重复）？

Sub CalenderExport()

    Dim ol As Outlook.Application
    Dim cal As Folder
    Dim exporter As CalendarSharing
    
    Dim FirstDayInMonth, LastDayInMonth As Variant
    Dim dtmDate As Date
    
    Dim mi As MailItem
    
    dtmDate = Date
    FirstDayInMonth = DateSerial(Year(Date), Month(Date), 0)
    LastDayInMonth = DateSerial(Year(Date), Month(Date) + 1, 0)
 
    Set ol = Application
    Set cal = ol.Session.GetDefaultFolder(olFolderCalendar)
    Set exporter = cal.GetCalendarExporter
    
    With exporter
        .CalendarDetail = olFullDetails
        .IncludeAttachments = False
        .IncludePrivateDetails = False
        .RestrictToWorkingHours = False
        .IncludeWholeCalendar = False
        .StartDate = FirstDayInMonth
        .EndDate = LastDayInMonth
        Set mi = .ForwardAsICal(olCalendarMailFormatEventList)
    End With
    
    With mi
        .Body = "Kalenderexport"
        .To = "[email protected]"
        .Subject = Date & " " & Time & " Calendar"
        .Send
    End With
    
End Sub

供参考：CalendarSharing.CalendarDetail-Eigenschaft（Outlook）

Answer 1

代码看起来不错，我没有看到任何可疑的地方。

但为了确保所有内容都正确导出，您可以尝试使用

Find

类的

FindNext

/

Restrict

或

Items

方法获取特定日期范围内的所有项目。因此，尝试运行以下代码示例，然后比较结果：

Sub DemoFindNext() 
 Dim myNameSpace As Outlook.NameSpace 
 Dim tdystart As Date 
 Dim tdyend As Date 
 Dim myAppointments As Outlook.Items 
 Dim currentAppointment As Outlook.AppointmentItem 
 Set myNameSpace = Application.GetNamespace("MAPI") 
 tdystart = VBA.Format(Now, "Short Date") 
 tdyend = VBA.Format(Now + 1, "Short Date") 
 Set myAppointments = myNameSpace.GetDefaultFolder(olFolderCalendar).Items 
 myAppointments.Sort "[Start]" 
 myAppointments.IncludeRecurrences = True 
 Set currentAppointment = myAppointments.Find("[Start] >= """ & _ 
 tdystart & """ and [Start] <= """ & tdyend & """") 
 While TypeName(currentAppointment) <> "Nothing" 
   MsgBox currentAppointment.Subject 
   Set currentAppointment = myAppointments.FindNext 
 Wend 
End Sub