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

Question

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

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

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

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

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

Answer 1

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

因为它是别人共享的日历。

您可以查看以下链接以获取此文件夹。

访问从共享邀请中打开的文件夹

Answer 2

我最终找到了一种适用于我的情况的解决方案。 我必须在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