Creating calendar item in non-default calendar

Hi Guys

I know it's not pretty, but I managed to get it to work:

Sub CreateAppointment2()

    Dim oApp As Outlook.Application
    Dim oItem As AppointmentItem
    Dim RowNumber As Integer
    Dim AppStartTime As String
    Dim AppEndTime As String
    
    Dim onamespace2 As Outlook.Namespace
    Dim recipient As Outlook.recipient
    Dim calendarFolder As Outlook.Folder
    Dim DestCal As String
                    
    RowNum = ActiveCell.Row
    
    On Error Resume Next
' check if Outlook is running
    Set oApp = GetObject("Outlook.Application")
    If Err <> 0 Then
' if not running, start it
    Set oApp = CreateObject("Outlook.Application")

    End If
    
   '' Get Start Date/Time
    If Worksheets("OrderDetails").Range("R" & RowNum).Value = "" Then
        AppStartTime = Now
    Else
        AppStartTime = Worksheets("OrderDetails").Range("R" & RowNum).Value + Worksheets("OrderDetails").Range("S" & RowNum).Value
    End If

'' Get End Time
    If Worksheets("OrderDetails").Range("T" & RowNum).Value = "" Then
        AppEndTime = AppStartTime + 0.5
    Else
        AppEndTime = Worksheets("OrderDetails").Range("R" & RowNum).Value + Worksheets("OrderDetails").Range("T" & RowNum).Value
    End If
    
    CalDest = Worksheets("OrderDetails").Range("U" & RowNum).Value
    
Set onamespace2 = oApp.GetNamespace("MAPI")
Set recipient = onamespace2.CreateRecipient(CalDest)

recipient.Resolve
            
If recipient.Resolved Then
    
    Set calendarFolder = onamespace2.GetSharedDefaultFolder(recipient, olFolderCalendar)
    Set oNameSpace = oApp.GetNamespace("MAPI")
    Set oItem = calendarFolder.Items.Add(olAppointmentItem)
    
    With oItem
        .Subject = Worksheets("OrderDetails").Range("N" & RowNum)
        .Start = AppStartTime
        .End = AppEndTime

        .AllDayEvent = False
        .Importance = olImportanceNormal
        .Location = Worksheets("OrderDetails").Range("O" & RowNum)

        .ReminderSet = True
        .ReminderMinutesBeforeStart = "10"
        .ReminderPlaySound = True
        .ReminderSoundFile = "C:\Windows\Media\Ding.wav"

        Select Case 1
            Case 1
                .Display
            Case 2
                .Save
        End Select

    End With
    
End If
    
    
Set oApp = Nothing
Set oItem = Nothing
Set onamespace2 = Nothing
Set recipient = Nothing




End Sub