从现有条目在其他用户的日历中创建条目

Question

我正在尝试使用此宏从已存在的约会创建约会。但是，每当我执行代码时，它都会创建一个新约会，其中我的默认日历是邀请的所有者。是否可以让我可以访问的另一个日历的所有者作为约会的所有者？

假设我的名字是“Tom”，我可以访问的日历属于“Jerry”，是否有可能从Jerry的日历中复制一个Jerry将成为所有者的约会？

Sub SHADOW()

    Dim objOL As Outlook.Application
    Dim objSelection As Outlook.Selection
    Dim objItem As Object
    Dim strName As String
    Set objOL = Outlook.Application

    'Get the selected item
    Select Case TypeName(objOL.ActiveWindow)
        Case "Explorer"
            Set objSelection = objOL.ActiveExplorer.Selection
            If objSelection.Count > 0 Then
                Set objItem = objSelection.Item(1)
            Else
                Result = MsgBox("No item selected. " & _
                            "Please make a selection first.", _
                            vbCritical, "OpenAppointmentCopy")
                Exit Sub
            End If

        Case "Inspector"
            Set objItem = objOL.ActiveInspector.CurrentItem

        Case Else
            Result = MsgBox("Unsupported Window type." & _
                        vbNewLine & "Please make a selection" & _
                        "in the Calendar or open an item first.", _
                        vbCritical, "OpenAppointmentCopy")
            Exit Sub
    End Select

    Dim olAppt As Outlook.AppointmentItem
    Dim olApptCopy As Outlook.AppointmentItem
    Set olApptCopy = Outlook.CreateItem(olAppointmentItem)

    'Copy the desired details to a new appointment item
    If objItem.Class = olAppointment Then
        Set olAppt = objItem

        With olApptCopy
            .Subject = olAppt.Subject
            .Location = olAppt.Location
            .Body = olAppt.Body
            .Categories = olAppt.Categories
            .AllDayEvent = olAppt.AllDayEvent
            .Start = olAppt.Start
            .End = olAppt.End
        End With

        'Display the copy
        olApptCopy.Display

    'Selected item isn't an appointment item
    Else
        Result = MsgBox("No appointment item selected. " & _
                    "Please make a selection first.", _
                    vbCritical, "OpenAppointmentCopy")
        Exit Sub
    End If

    'Clean up
    Set objOL = Nothing
    Set objItem = Nothing
    Set olAppt = Nothing
    Set olApptCopy = Nothing

End Sub