我有一个脚本,可以将约会添加到共享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。
感谢您的帮助。
答案 0 :(得分:-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/