method to add appointment in non default calendar through excel

Question

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.

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.

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...

Sub 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?

Answer 1

The line

Set OLAppointment = miCalendario.Item.Add(olAppointmentItem)

must be

 Set OLAppointment = miCalendario.Items.Add(olAppointmentItem)