Как ссылаться на группу или общий календарь в Outlook 365 Exchange с помощью Excel?

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

Получается не так, как папка календаря.

Поскольку это календарь, которым пользуются другие.

Вы можете увидеть следующую ссылку, чтобы получить эту папку.

Доступ к папке, открытой по приглашению для обмена