vba 通过excel在非默认日历中添加约会的方法
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/19723597/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
method to add appointment in non default calendar through excel
提问by Adrián Pulido del Castillo
Im trying to add appointments to Outlook through Excel with VBA and all its ok when i add the appointment to the default calendar but i dont know the method to add this appointment to an another calendar in Outlook.
当我将约会添加到默认日历时，我尝试通过 Excel 使用 VBA 将约会添加到 Outlook，一切正常，但我不知道将此约会添加到 Outlook 中的另一个日历的方法。
The next code is for default calendar:
下一个代码用于默认日历：
Sub Appointments()
子约会()
Const olAppointmentItem As Long = 1
Dim OLApp As Object
Dim OLNS As Object
Dim OLAppointment As Object
On Error Resume Next
Set OLApp = GetObject(, "Outlook.Application")
If OLApp Is Nothing Then Set OLApp = CreateObject("Outlook.Application")
On Error GoTo 0
If Not OLApp Is Nothing Then
Set OLNS = OLApp.GetNamespace("MAPI")
OLNS.Logon
Set OLAppointment = OLApp.Item.Add(olAppointmentItem)
OLAppointment.Subject = Range("A1").Value
OLAppointment.Start = Range("C3").Value
OLAppointment.Duration = Range("C1").Value
OLAppointment.ReminderMinutesBeforeStart = Range("D1").Value
OLAppointment.Save
Set OLAppointment = Nothing
Set OLNS = Nothing
Set OLApp = Nothing
End If
End Sub
结束子
Im trying to use the "Folders" object to set the non default calendar but excel retrieves me a compile error always.
我试图使用“文件夹”对象来设置非默认日历，但 excel 总是检索我一个编译错误。
Sub Appointments()
子约会()
Const olAppointmentItem As Long = 1
Dim OLApp As Object
Dim OLNS As Object
Dim OLAppointment As Object
Dim miCalendario As Object
On Error Resume Next
Set OLApp = GetObject(, "Outlook.Application")
If OLApp Is Nothing Then Set OLApp = CreateObject("Outlook.Application")
On Error GoTo 0
If Not OLApp Is Nothing Then
Set OLNS = OLApp.GetNamespace("MAPI")
OLNS.Logon
Set miCalendario = OLApp.Session.GetDefaultFolder(9).Folders("a")
Set OLAppointment = miCalendario.Item.Add(olAppointmentItem)
OLAppointment.Subject = Range("A1").Value
OLAppointment.Start = Range("C3").Value
OLAppointment.Duration = Range("C1").Value
OLAppointment.ReminderMinutesBeforeStart = Range("D1").Value
OLAppointment.Save
Set OLAppointment = Nothing
Set OLNS = Nothing
Set OLApp = Nothing
End If
End Sub
结束子
Anyone can help me please?
任何人都可以帮助我吗？
Thanks in advance.
提前致谢。
EDIT:
编辑：
I have made this script for Outlook and im trying to modify for Excel...
我已经为 Outlook 制作了这个脚本，我正在尝试为 Excel 修改...
Sub AddContactsFolder()
子 AddContactsFolder()
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myNewFolder As Outlook.AppointmentItem
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderCalendar).Folders("aa")
MsgBox myFolder
Set myNewFolder = myFolder.Items.Add(olAppointmentItem)
With myNewFolder
.Subject = "aaaaa"
.Start = "10/11/2013"
.ReminderMinutesBeforeStart = "20"
.Save
End With
End Sub
结束子
Anyone can help me with this?
任何人都可以帮助我吗？
回答by Dmitry Streblechenko
The line
线
Set OLAppointment = miCalendario.Item.Add(olAppointmentItem)
设置 OLAppointment = miCalendario.Item.Add(olAppointmentItem)
must be
必须是
Set OLAppointment = miCalendario.Items.Add(olAppointmentItem)
