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

Question

下午好，

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

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

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

另一个选项来自这里：

Determining selected Outlook Calendar date with VBA

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

    Set oExpl = Application.ActiveExplorer

如何解决此问题并让我的日期显示在 Outlook 日历上？我可以扩大我的范围，包括测量员的名字吗？

感谢和问候

更新：

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

 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

我得到 Type Mismatch，因为调试器会突出显示该行：

 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 文章很有帮助。