从Excel将约会保存到共享Outlook日历

Question

我有一个脚本，可将约会添加到共享Outlook日历中。 以下脚本可在日历的主机上运行，​​但不能在其他PC上运行。 代码是：

Sub OC1SOAK()
Dim oApp As Object
Dim oNameSpace As Namespace
Dim oFolder As Object
Dim OutTaskOC11 As Outlook.AppointmentItem
Dim OutTaskOC12 As Outlook.AppointmentItem
Dim OutTaskOC115 As Outlook.AppointmentItem
Set oApp = New Outlook.Application
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetFolderFromID("*folderidhere*")
With oFolder
    Set OutTaskOC11 = oFolder.Items.ADD(olAppointmentItem)
    Set OutTaskOC12 = oFolder.Items.ADD(olAppointmentItem)
    Set OutTaskOC115 = oFolder.Items.ADD(olAppointmentItem)
    With OutTaskOC11
        .Subject = TR.Text + "   " + Fuel1.Text + "   " + "Vapor" + "   " + "Start"
        .Start = startdate.Text
        .End = startdate.Text
    End With
    With OutTaskOC12
        .Subject = TR.Text + "   " + Fuel1.Text + "   " + "Submerged"
        .Start = Format(DateValue(startdate.Text) + Val("3"), "mm/dd/yyyy")
        .End = Format(DateValue(startdate.Text) + Val("3"), "mm/dd/yyyy")
    End With
        With OutTaskOC115
        .Subject = TR.Text + "   " + "Finished"
        .Start = Format(DateValue(startdate.Text) + Val("6"), "mm/dd/yyyy")
        .End = Format(DateValue(startdate.Text) + Val("6"), "mm/dd/yyyy")
    End With
    OutTaskOC11.SAVE
    OutTaskOC12.SAVE
    OutTaskOC115.SAVE
End With
End Sub

我得到的错误是，

运行时错误'-2147220991（80040201）'：操作失败。 消息传递接口返回了未知错误。 如果问题仍然存在，请重新启动Outlook。

有人有什么想法吗？ 我已经检查了日历共享权限。 我最初以为是使用Createitems / move的结果，所以我改用了items.add。

任何帮助表示赞赏。

Answer 1

我没有在其他PC上测试过，但是下面的代码对我来说很好用。

Private Sub Add_Appointments_To_Outlook_Calendar()

    'Include Microsoft Outlook nn.nn Object Library from Tools -> References
    Dim oAppt As AppointmentItem
    Dim Remind_Time As Double

    i = 2
    Subj = ThisWorkbook.Sheets(1).Cells(i, 1)

    'Loop through entire list of Reminders to be added
    While Subj <> ""
        Set oAppt = Outlook.Application.CreateItem(olAppointmentItem)

        oAppt.Subject = Subj
        oAppt.Location = ThisWorkbook.Sheets(1).Cells(i, 2)
        oAppt.Start = ThisWorkbook.Sheets(1).Cells(i, 3)
        Remind_Time = ThisWorkbook.Sheets(1).Cells(i, 4) * 1 * 60
        oAppt.ReminderMinutesBeforeStart = Remind_Time
        oAppt.AllDayEvent = True
        oAppt.Save

        i = i + 1
        Subj = ThisWorkbook.Sheets(1).Cells(i, 1)
    Wend
    MsgBox "Reminder(s) Added To Outlook Calendar"

End Sub

' https://www.slipstick.com/developer/create-appointments-spreadsheet-data/

' https://blogs.msdn.microsoft.com/brunoterkaly/2014/07/24/scheduling-appointments-in-outlook-from-excel/