VBA Excel 将日期单元格与 Outlook 日历事件同步

Question

下午好，

我一直在努力与 MS Excel 的 Outlook 日历同步。我希望我的单元格与日期作为事件出现在这个日历中。

我为此找到的最佳代码来自这里：

Excel Create an Outlook calendar event

但是，由于代码不完整，问题已关闭。

在我的示例中尝试此代码

 Sub Calendaroutlookevent()

 Dim objOutlook As Outlook.Application
 Dim objNamespace As Outlook.Namespace
 Dim items As Outlook.Folder, objCalendar As Outlook.Folder, objapt As Outlook.Folder
 Dim wb As Workbook
 Dim ws As Worksheet
 Dim Dt As Date

 Set wb = ThisWorkbook
 Set ws = wb.Sheets("Sheet1")
 Set Dt = ws.Range("B2:C6")  ' Dates with surveyors included. Maybe some Match option here?


 Const olFolderCalendar = 9
 Const olAppointmentItem = 1 '1 = Appointment

 Set objOutlook = CreateObject("Outlook.Application")

'Set objOutlook = GetObject(, "Outlook.Application")  ' outlook already open
 Set objNamespace = objOutlook.GetNamespace("MAPI")
 Set items = objNamespace.GetDefaultFolder(olFolderCalendar).items

 Set objCalendar = objNamespace.GetDefaultFolder(olFolderCalendar).Folders("subfolder")
 Set objCalendar = objNamespace.GetDefaultFolder(olFolderCalendar) ' main calender
 Set objapt = objCalendar.items.add(olAppointmentItem)
 objapt.Subject = "Test" 'Owner
 objapt.Start = Dt + TimeValue("08:00:00")
 objapt.Duration = 60 * 8 'Duration(in minutes) OR End(I'm not sure so try both)
 objapt.End = Dt + TimeValue("16:00:00")
 objapt.Save

 End Sub

现在调试器显示 "Object required" 指向行：Set Dt = ws.Range("C2:C6")

如果我按照下面的 Date 保留原始声明，那么

 Sub Calendaroutlookevent()

 Dim objOutlook As Outlook.Application
 Dim objNamespace As Outlook.Namespace
 Dim items As Outlook.Folder, objCalendar As Outlook.Folder, objapt As Outlook.Folder


 Const olFolderCalendar = 9
 Const olAppointmentItem = 1 '1 = Appointment

 Set objOutlook = CreateObject("Outlook.Application")

 'Set objOutlook = GetObject(, "Outlook.Application")  ' outlook already open
 Set objNamespace = objOutlook.GetNamespace("MAPI")
 Set items = objNamespace.GetDefaultFolder(olFolderCalendar).items

 Set objCalendar = objNamespace.GetDefaultFolder(olFolderCalendar).Folders("subfolder")
 Set objCalendar = objNamespace.GetDefaultFolder(olFolderCalendar) ' main calender
 Set objapt = objCalendar.items.add(olAppointmentItem)
 objapt.Subject = "Test" 'Owner
 objapt.Start = Date + TimeValue("08:00:00")
 objapt.Duration = 60 * 8 'Duration(in minutes) OR End(I'm not sure so try both)
 objapt.End = Date + TimeValue("16:00:00")
 objapt.Save

 End Sub

然后调试器对以下行说 "Type-mismatch"：

 Set items = objNamespace.GetDefaultFolder(olFolderCalendar).items

另一个选项来自这里：

但即使我使用这个纯代码，我也会收到错误：“对象不支持此属性或方法 ” 指向该行：

    Set oExpl = Application.ActiveExplorer

如何解决这个问题并使我的日期显示在 Outlook 日历中？我可以扩大我的范围，包括 Surveyor 名称吗？

感谢和问候

更新：

我的代码的最新版本如下所示：

 Sub Calendaroutlookevent()

 Dim objOutlook As Outlook.Application
 Dim objNamespace As Outlook.Namespace
 Dim items As Outlook.items
 Dim objCalendar As Outlook.Folder, objapt As Outlook.Folder


  Const olFolderCalendar = 9
  Const olAppointmentItem = 1 '1 = Appointment

 Set objOutlook = CreateObject("Outlook.Application")

 'Set objOutlook = GetObject(, "Outlook.Application")  ' outlook already open
 Set objNamespace = objOutlook.GetNamespace("MAPI")
 Set items = objNamespace.GetDefaultFolder(olFolderCalendar).items

 Set objCalendar = objNamespace.GetDefaultFolder(olFolderCalendar) ' main 
  calender
 Set items = objCalendar.items
 Set objapt = items.add(olAppointmentItem)

 objapt.Subject = "Test" 'Owner
 objapt.Start = Date + TimeValue("08:00:00")
 objapt.Duration = 60 * 8 'Duration(in minutes) OR End(I'm not sure so try 
 both)
 objapt.End = Date + TimeValue("16:00:00")
 objapt.Save

 End Sub

我得到 类型不匹配，因为调试器突出显示了以下行：

 Set objapt = items.add(olAppointmentItem)

Answer 1

首先，您需要正确声明对象：

Dim items As Outlook.Items

其次，不需要两次访问相同的对象：

Set items = objNamespace.GetDefaultFolder(olFolderCalendar).items

Set objCalendar = objNamespace.GetDefaultFolder(olFolderCalendar).Folders("subfolder")
Set objCalendar = objNamespace.GetDefaultFolder(olFolderCalendar) ' main calender
Set objapt = objCalendar.items.add(olAppointmentItem)

您可以改用以下代码：

Set objCalendar = objNamespace.GetDefaultFolder(olFolderCalendar) ' main calender
Set items = objCalendar.Items
Set objapt = items.add(olAppointmentItem)

objapt.Subject = "Test" 'Owner
objapt.Start = Date + TimeValue("08:00:00")
objapt.Duration = 60 * 8 'Duration(in minutes) OR End(I'm not sure so try both)
objapt.End = Date + TimeValue("16:00:00")
objapt.Save

最后，您可能会发现这篇 Getting started with VBA in Office 文章很有帮助。

VBA Excel 将日期单元格与 Outlook 日历事件同步

VBA Excel synchronising the date cells with Outlook calendar events

excel

outlook

vba

calendar