如何使用 Excel 在 Outlook 365 Exchange 中引用组或共享日历？

Question

我正在尝试让多个用户能够使用 Excel 将约会添加到共享日历。

以下代码对我有用。我拥有共享日历，它位于 Outlook365 的日历文件夹中。

Sub CreateAppt()

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


Set objOutlook = CreateObject("Outlook.Application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
Set items = objNameSpace.GetDefaultFolder(olFolderCalendar).items

'check to see if calendar exists
For i = 1 To objNameSpace.GetDefaultFolder(olFolderCalendar).Folders.Count

If objNameSpace.GetDefaultFolder(olFolderCalendar).Folders.Item(i).Name = "Maintenance Task Manager" Then

    'set calendar name and set new appointment
    Set objCalendar = objNameSpace.GetDefaultFolder(olFolderCalendar).Folders("Maintenance Task Manager")
    Set objapt = objCalendar.items.Add(olAppointmentItem)

    'create appointment for PM
    With objapt
        .Subject = "PM Due for " & ActiveSheet.Range(PMcell).Offset(0, -6).Value
        .Location = ActiveSheet.Range(PMcell).Value
        .AllDayEvent = True
        .Start = ActiveSheet.Range(PMcell).Value
        .ReminderSet = True
        .ReminderMinutesBeforeStart = 10080
        If Not emailaddy = "" Then
            .Recipients.Add (emailaddy)
        End If
        .BusyStatus = olFree
        .Categories = "Equipment PM's"
        .body = PersonResponsible & ", you are responsible for the PM on this piece of equipment due on " & Format(DueDate, "Long Date")
    .Save
    End With
    Exit Sub
End If
Next i
End Sub

代码在日历文件夹中查找名为“维护任务管理器”的日历。

问题是在其他用户的 Outlook 中，此文件夹不在日历文件夹中，因此无法找到。它似乎不在任何文件夹中。

Answer 1

我最终找到了一个在我的情况下效果很好的解决方案。我必须在 Outlook365 中添加一个新组并与具有读/写权限的用户共享。在他们接受后，他们必须将小组日历添加到他们的收藏夹中。

代码如下，感兴趣的朋友可以参考一下。

Sub Test()

Const olFolderCalendar = 9
Const olModuleCalendar = 1
Const olAppointmentItem = 1
Dim answer As Integer
Dim objNS
Dim objExpCal
Dim objNavMod
Dim objNavGroup
Dim objNavFolder
Dim objFolder
Dim colExpl

Set oApp = CreateObject("Outlook.Application")
Set objNS = oApp.Session
Set colExpl = oApp.Explorers
Set objExpCal = objNS.GetDefaultFolder(olFolderCalendar).GetExplorer
Set objNavMod = objExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)

For Each objNavGroup In objNavMod.NavigationGroups
    For Each objNavFolder In objNavGroup.NavigationFolders
        If Not objNavFolder = "SHARED CALENDAR NAME" Then '<<must be named exactly as in the nav pane in outlook
            GoTo NxtGroup
        End If
        On Error Resume Next
        Set objFolder = objNavFolder.Folder

NxtGroup:
    Next
Next

Set objCalendar = objFolder
Set objapt = objCalendar.items.Add(olAppointmentItem)

    'create an appointment to schedule PM with outside contractor
    With objapt
        .Subject = "SUBJECT HERE"
        .Location = "LOCATION HERE
        .AllDayEvent = True 'or comment out and add an .End = line
        .Start = "SOME DATE HERE"
        .ReminderSet = True
        .ReminderMinutesBeforeStart = 10080
        .BusyStatus = olFree
        .Categories = "MUST HAVE SOMETHING HERE TO BE ABLE TO DELETE THE EVENT IF NEEDED"
        .body = ""
        .Display 'or .Save
    End With

Set objNS = Nothing
Set objNavMod = Nothing
Set objNavGroup = Nothing
Set objNavFolder = Nothing
Set objFolder = Nothing
Set colExpl = Nothing

End Sub

Answer 2

获取方式与日历文件夹不同。

因为是别人共享的日历。

您可以通过以下链接获取该文件夹。

Access a Folder Opened from a Sharing Invitation