每次保存工作簿时如何创建 Outlook 日历条目？

Question

我想在每次保存工作簿时创建一个 Outlook 日历会议请求。

需要将会议请求添加到共享邮箱，以便所有有权访问的用户都能看到会议邀请。

到目前为止，它在我的个人日历中添加了一个条目。

Private Sub Workbook_AfterSave(ByVal Success As Boolean)
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("2021") 'define your sheet!
  
    Dim olApp As Object  'create outlook application
    Set olApp = CreateObject("Outlook.Application")

    Dim olNS As Object 'get namespace
    Set olNS = olApp.GetNamespace("MAPI")

    'define constants if using late binding
    Const olFolderCalendar As Long = 9
    Const olAppointmentItem As Long = 1

    Dim olRecItems As Object 'get all appointments
    Set olRecItems = olNS.GetDefaultFolder(olFolderCalendar)

    Dim strFilter As String  'filter for appointments
    Dim olFilterRecItems As Object 'filtered appointments

    Dim iRow As Long
    iRow = 3

    Do Until Trim$(ws.Cells(iRow, 3).Value) = vbNullString
        'filter appointments for subject
        strFilter = "[Subject] = '" & Trim$(ws.Cells(iRow, 4).Value) & "'"
        Set olFilterRecItems = olRecItems.Items.Restrict(strFilter)

        If olFilterRecItems.Count = 0 Then 'if subject does not exist
            With olApp.CreateItem(olAppointmentItem)
                .Subject = ws.Cells(iRow, 4).Value
                .Start = ws.Cells(iRow, 3).Value
                .AllDayEvent = True
                .BusyStatus = 5
                .ReminderSet = True
                .Save
            End With
            ws.Cells(iRow, 3).Interior.ColorIndex = 50
        End If

        iRow = iRow + 1
    Loop
End Sub

更新：

我设法得到了这个。现在的问题是它只会为最后一行创建日历条目。

Private Sub Workbook_AfterSave(ByVal Success As Boolean)
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("2020") 'define your sheet!
  
    Dim olApp As Object  'create outlook application
    Set olApp = CreateObject("Outlook.Application")

    Dim olNS As Object 'get namespace
    Set olNS = olApp.GetNamespace("MAPI")
    
    Dim olAppItem As Outlook.AppointmentItem
    Dim myRequiredAttendee As Outlook.Recipient
        
    'define constants if using late binding
    Const olFolderCalendar As Long = 9
    Const olAppointmentItem As Long = 1

    Dim olRecItems As Object 'get all appointments
    Set olRecItems = olNS.GetDefaultFolder(olFolderCalendar)
        
    Set olAppItem = olRecItems.Items.Add(olAppointmentItem)

    Dim strFilter As String  'filter for appointments
    Dim olFilterRecItems As Object 'filtered appointments

    Dim iRow As Long
    iRow = 3

    Do Until Trim$(ws.Cells(iRow, 3).Value) = vbNullString
        'filter appointments for subject
        strFilter = "[Subject] = '" & Trim$(ws.Cells(iRow, 4).Value) & "'"
        Set olFilterRecItems = olRecItems.Items.Restrict(strFilter)

        If olFilterRecItems.Count = 0 Then 'if subject does not exist
            With olAppItem
            Set myRequiredAttendee = .Recipients.Add("email address")
            myRequiredAttendee.Type = olRequired
                .MeetingStatus = olMeeting
                .ReminderMinutesBeforeStart = 30
                .Subject = ws.Cells(iRow, 4).Value
                .Start = ws.Cells(iRow, 3).Value
                .AllDayEvent = True
                .BusyStatus = 5
                .ReminderSet = True
                .Send
            End With
            ws.Cells(iRow, 3).Interior.ColorIndex = 50
        End If

        iRow = iRow + 1
    Loop
End Sub

Answer 1

而不是下面的代码：

Dim olRecItems As Object 'get all appointments
Set olRecItems = olNS.GetDefaultFolder(olFolderCalendar)

您需要使用NameSpace.GetSharedDefaultFolder 方法返回一个Folder 对象，该对象代表指定用户的指定默认文件夹。此方法用于委派方案，其中一个用户已将一个或多个默认文件夹（例如，他们的共享日历文件夹）的访问权限委派给另一个用户。例如：

Sub ResolveName() 
 Dim myNamespace As Outlook.NameSpace 
 Dim myRecipient As Outlook.Recipient 
 Dim CalendarFolder As Outlook.Folder 
 Set myNamespace = Application.GetNamespace("MAPI") 
 Set myRecipient = myNamespace.CreateRecipient("Eugene Astafiev") 
 myRecipient.Resolve 
 If myRecipient.Resolved Then 
 Call ShowCalendar(myNamespace, myRecipient) 
 End If 
End Sub 
 
Sub ShowCalendar(myNamespace, myRecipient) 
 Dim CalendarFolder As Outlook.Folder 
 Set CalendarFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar) 
 CalendarFolder.Display 
End Sub