Appointment in non default Outlook Calendar

[tomv]

I use 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. There's more in this procedure, but I just posted the relevant portion.
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

 

[PeterF]

I move the appointment after creation like:

Dim moveCal As AppointmentItem
Dim Calfolder As Outlook.Folder

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

Set Calfolder = GetFolderPath("\\User@domain.com\Calendar")

' set the category after it's moved to force EAS to sync changes
Set moveCal = cAppt.Move(Calfolder)
moveCal.Categories = "moved"
moveCal.Save


'******************
Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
    Dim oFolder As Outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer
    Dim SubFolders As Outlook.Folders
    
    On Error GoTo GetFolderPath_Error
    
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
'Convert folderpath to array
    FoldersArray = Split(FolderPath, "\")
    Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderPath = Nothing
            End If
        Next
    End If
'Return the oFolder
    Set GetFolderPath = oFolder
Exit Function
GetFolderPath_Error:
    Set GetFolderPath = Nothing
Exit Function
End Function

 

[tomv]

Thanks PeterF.
I will try this and post back.
I understand the code, except for Set Calfolder = GetFolderPath("\\User@domain.com\Calendar")

Do I need to sibstitute user details here? I am using Outlook 2007 and wondering if this is for exchange.

 

[PeterF]

In my case it is for exchange, check the properties of the folder where you want to save and use that (including the sub folder).