Non Default Outlook Calendar

[Tom]

I have the code below which creates an appointment in Outlook default calendar. I need to add a few lines to create the appointment to an alternative calendar in the same pst file. I need to choose between three calendars in which to create the appointment and plan to select the calendar name from a list on the form.
Any help welcome.

Dim objOutlook As Outlook.Application
Dim objAppt As Outlook.AppointmentItem
Set objOutlook = CreateObject("Outlook.Application")
Set objAppt = objOutlook.CreateItem(olAppointmentItem)

With objAppt
.Start = Me!ApptDate & " " & Me!ApptTime
.Duration = Me!ApptLength
.Subject = Me!Appt

.Save
.Close (olSave)
End With

Set objAppt = Nothing
Set objOutlook = Nothing

[Patrick Wood]

One way to do this is to use the PickFolder Method as the code below demonstrates. The code opens an Outlook Dialog allowing you to "Pick" the folder you want. The code verifies the Folder selected is a Calendar Folder.

Sub SaveAppointmentInFolder()

Dim objOutlook As Outlook.Application
Dim objAppt As Outlook.AppointmentItem

Dim objNameSpace As Outlook.NameSpace
Dim objFolder As Outlook.Folder

On Error GoTo ErrHandle

Set objOutlook = CreateObject("Outlook.Application")

'Instantiate the MAPI Namespace needed to get a Folder.
Set objNameSpace = objOutlook.GetNamespace("MAPI")

'Use label here to return here if wrong type of Folder is selected.
SelectFolder:
'Use PickFolder Method to select the Folder needed.
Set objFolder = objNameSpace.PickFolder

'Make sure a Folder has been chosen.
If objFolder Is Nothing Then
MsgBox "A Folder was not selected." & vbCrLf _
& vbCrLf & "Please try again and select a Calendar Folder.", vbExclamation
GoTo ExitHere
Else
'Verify this is a Calendar folder.
If objFolder.DefaultItemType <> olAppointmentItem Then
MsgBox "Please select a Calendar Folder."
GoTo SelectFolder
End If
End If

' Create a new Appointment in the selected folder
Set objAppt = objFolder.Items.Add

With objAppt
.Start = Me!ApptDate & " " & Me!ApptTime
.Duration = Me!ApptLength
.Subject = Me!Appt
.Save
.Close (olSave)
End With

ExitHere:
On Error Resume Next
Set objFolder = Nothing
Set objNameSpace = Nothing

Set objAppt = Nothing
Set objOutlook = Nothing

Exit Sub

ErrHandle:
MsgBox "Error #" & Err.Number & " " & Err.Description _
& vbCrLf & " In Procedure SaveAppointmentInFolder"
Resume ExitHere

End Sub