VBA 共享日歷會議創建者

Question

我正在使用在網上找到的修改代碼，但在 Outlook 中查找共享日歷時遇到問題。

Sub SharedCalendarEventCreator()
Dim olApp As Outlook.Application
Dim outNameSpace As Namespace
Dim outSharedName As Outlook.Recipient
Dim outCalendarFolder As MAPIFolder
Dim olAppItem As Outlook.AppointmentItem
Dim r As Long
Dim eduSheet As Worksheet


On Error Resume Next
Worksheets("Schedule").Activate
Set olApp = GetObject("", "Outlook.Application")
On Error GoTo 0
    If olApp Is Nothing Then
    On Error Resume Next
    Set olApp = CreateObject("Outlook.Application")
    On Error GoTo 0
        If olApp Is Nothing Then
        MsgBox "Outlook is not available!"
        Exit Sub
        End If
    End If

    Set outNameSpace = olApp.GetNamespace("MAPI")
    Set outCalendarFolder = outNameSpace.Folders("Lunch Calendar")
    Set outCalendarFolder = outCalendarFolder.Folders("Calendar")
    Set olAppItem = outCalendarFolder.Items.Add(olAppointmentItem)

  r = 7

  Do Until Trim$(Cells(r, 1).Value) = ""
    With olAppItem
      .Subject = "SOF " & Cells(1, 2).Value & " " & Cells(2, 2).Value & " " & Cells(3, 2).Value & " " & Cells(r, 2).Value
      .Start = Cells(r, 1).Value
    vArray = Split(Cells(4, 2).Value2, ";")
    For Each vElement In vArray
      '.Recipients.Add .Recipients.Add(vElement)
      Next vElement
      .MeetingStatus = olMeeting
      .AllDayEvent = True
      .Body = Cells(r, 3).Value
      .ResponseRequested = False
      .Send
      r = r + 1
    End With
  Loop
Set olAppItem = Nothing
Set outCalendarFolder = Nothing
Set outNameSpace = Nothing
Set olApp = Nothing
End Sub

日歷位置的圖片：

我相信問題出在這些方面，但我試圖在沒有任何運氣的情況下改變它們：

Set outNameSpace = olApp.GetNamespace("MAPI")
Set outCalendarFolder = outNameSpace.Folders("Lunch Calendar")
Set outCalendarFolder = outCalendarFolder.Folders("Calendar")
Set olAppItem = outCalendarFolder.Items.Add(olAppointmentItem)

我收到的錯誤：

當我點擊調試時，這是它突出顯示的行：

任何幫助是極大的贊賞。

Answer 1

將文件夾樹從“janedoe@gmail”導航到“日歷”再到“午餐日歷”。

Option Explicit

Sub SharedCalendarEventCreator()

    ' Early binding - Set reference to Outlook XX.X Object Library
    Dim olApp As Outlook.Application
    Dim outNameSpace As Outlook.Namespace
    
    Dim outMailboxFolder As Outlook.Folder
    Dim outCalendarFolder As Outlook.Folder
    Dim outCalendarSubFolder As Outlook.Folder
    
    Dim olAppItem As Outlook.AppointmentItem
        
    On Error Resume Next
    Set olApp = GetObject("", "Outlook.Application")
    On Error GoTo 0
    If olApp Is Nothing Then
        On Error Resume Next
        Set olApp = CreateObject("Outlook.Application")
        On Error GoTo 0
        If olApp Is Nothing Then
            MsgBox "Outlook is not available!"
            Exit Sub
        End If
    End If

    Set outNameSpace = olApp.GetNamespace("MAPI")
    
    Set outMailboxFolder = outNameSpace.Folders("janedoe@gmail")
    Set outCalendarFolder = outMailboxFolder.Folders("Calendar")
    Set outCalendarSubFolder = outCalendarFolder.Folders("Lunch Calendar")
        
    'Set ActiveExplorer.CurrentFolder = outCalendarSubFolder
    
    Set olAppItem = outCalendarSubFolder.Items.Add(olAppointmentItem)
    olAppItem.Display
    
    Set olAppItem = Nothing
    Set outCalendarSubFolder = Nothing
    Set outCalendarFolder = Nothing
    Set outMailboxFolder = Nothing
    Set outNameSpace = Nothing
    Set olApp = Nothing
    
End Sub