使用VBA宏导出带有定期会议的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 = "[e-mail]"
.Subject = Date & " " & Time & " Calendar"
.Send
End With

End Sub

和本网站供参考:https://learn.microsoft.com/de-de/office/vba/api/outlook.calendarsharing.calendardetail

Thanks in advance

Answer 1

代码看起来不错，我没有发现任何可疑之处。

但是为了确保所有内容都正确导出，您可以尝试使用Items类的Find/FindNext或Restrict方法来获取特定日期范围的所有项目。因此，尝试运行以下代码示例，然后比较结果:

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