Issue selecting shared calendar from macro for appointment

[StillUnderstanding]

Hello,

I am running the below code to create a calendar appointment but it is always creating the appointment from the main calendar and not the shared one. I am having to use "Send Keys" to change it but its not always working.

Can anyone help me with this please!?

Option Explicit

'Notes:
'Tab: mail id should be in whether P column or AJ column



Sub Bulk_Invites()
 Dim outApp As Object
    Dim outNameSpace As Object
    Dim outSharedName As Object
    Dim outCalendarFolder As Object
    Dim outAppointment As Object
Const olAppointmentItem As Long = 1
Dim olApp As Object
Dim OLNS As Object

Dim OLAppointment As Object
Dim SentOnBehalfOfName As Object
Dim i As Byte
Dim cellrng As Range, Rng As Range
Dim attach
Dim strFolderPath As String
Dim strFileName As String
Dim optionalAppointment As Object
Dim sentMailItem As Object


Dim SharedMailboxEmail As String
    
    SharedMailboxEmail = "mysharedmailbox@me.me" 
 Const olFolderCalendar = 9
    'Const olAppointmentItem = 1
    Const olImportanceNormal = 1

' Set outCalendarFolder = outCalendarFolder.Folders("mysharedmailbox@me.me ")


    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    Set olApp = outNameSpace.CreateRecipient(SharedMailboxEmail)
    If olApp Is Nothing Then Set olApp = CreateObject("Outlook.Application")
    On Error GoTo 0
    
    If Not olApp Is Nothing Then
For i = 1 To 10 'Cells(2, Columns.Count).End(xlToLeft).Column - 1
    
  
    
    
    Set OLNS = olApp.GetNamespace("MAPI")
    OLNS.Logon
    
    If LCase(Trim(Cells(3, i + 1))) = "yes" And Len(Trim(Cells(7, i + 1))) = 1 Then
     'delay running the next invite for 15 seconds
       Application.Wait (Now + TimeValue("0:00:15"))
      
      
        Set OLAppointment = olApp.CreateItem(olAppointmentItem)
        
         sentMailItem.SentOnBehalfOfName = Cells(25, i + 1).Value
          OLAppointment.SentOnBehalfOfName = Cells(25, i).Value
        
        'OLAppointment.MeetingStatus = olMeeting
        
        Set attach = OLAppointment.Attachments
        'Set optionalAppointment = olApp.CreateItem(olAppointmentItem)
        'Set sentMailItem = olApp.CreateItem(olAppointmentItem)
        
        On Error Resume Next
          sentMailItem.SentOnBehalfOfName = Cells(25, i + 1).Value
          OLAppointment.SentOnBehalfOfName = Cells(25, i).Value
        OLAppointment.Subject = Cells(27, i + 1).Value 'subject
        OLAppointment.Start = Cells(19, i + 1).Value + Cells(21, i + 1).Value 'start
        OLAppointment.End = Cells(19, i + 1).Value + Cells(23, i + 1).Value 'end
        'Mail Body with Greetings
        'OLAppointment.Location = "Microsoft Teams Meeting"
        OLAppointment.Body = "Hi " & Cells(31, i + 1).Value & vbCr _
        & vbCr _
        & Cells(33, i + 1).Value & vbCr
        
        OLAppointment.Display
        '=============To_Start=================================================================================
        For Each cellrng In Sheets(Cells(5, i + 1).Value).Range("B7:B" & Sheets(Cells(5, i + 1).Value).Cells(Rows.Count, 2).End(xlUp).Row)
        'Set Rng = Sheets(Cells(5, i + 1).Value).Range("B7:B" & Sheets(Cells(5, i + 1).Value).Cells(Rows.Count, 2).End(xlUp).Row)
        'For Each cellrng In Rng
        If cellrng = Cells(7, i + 1) Then
        If Cells(9, i + 1) = "P" Then
        'If cellrng = Cells(7, i + 1) Or cellrng = LCase(Cells(7, i + 1)) Or cellrng = UCase(Cells(7, i + 1)) Then
           ' If UCase(Trim(Cells(9, i + 1))) = "P" Then
                OLAppointment.Recipients.Add cellrng.Offset(0, 14).Value
            Else
                OLAppointment.Recipients.Add cellrng.Offset(0, 35).Value
            End If
                OLAppointment.Save
                'OLAppointment.Send
                
            End If
        Next cellrng
        '<<<<<<<<<<<<<<<<<<<<<<<<<<To_End>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
        '=============Additional_To_Start=======================================================================
        If Cells(15, i + 1) <> "" Then
            OLAppointment.Recipients.Add Cells(15, i + 1).Value
        End If
        '<<<<<<<<<<<<<<<<<<<<<<<<<<Additional_To_End>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
        '=============To_add_Optional=================================================================================
         If Cells(17, i + 1) <> "" Then
         Set optionalAppointment = OLAppointment.Recipients.Add(Cells(17, i + 1).Value)
         optionalAppointment.Type = 2
         End If
         'on Behalf
        If Cells(25, i + 1) <> "" Then
           sentMailItem.SentOnBehalfOfName = Cells(25, i + 1).Value
        End If
         '<<<<<<<<<<<<<<<<<<<<<<<<<<To_End>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
        '============Attachment_Start==========================================================================
        If Cells(29, i + 1) <> "" Then
        strFolderPath = Cells(29, i + 1).Value
        strFileName = Dir(strFolderPath)
        While Len(strFileName) > 0
              attach.Add (strFolderPath & strFileName)
              strFileName = Dir
        Wend
        End If
        '<<<<<<<<<<<<<<<<<<<<<<<<<<Attachment_End>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
        'Application.Wait (Now + TimeValue("0:00:01"))
        OLAppointment.Send
        
        Application.Wait (Now + TimeValue("0:00:01"))
         SendKeys "{F10}", True
            SendKeys "H", True
            SendKeys "i", True
                     SendKeys "{F10}", True
            SendKeys "H", True
            SendKeys "TM", True
            SendKeys "{F10}", True
            Application.Wait (Now + TimeValue("0:00:03"))
        'OLAppointment.Display
                'SendKeys "{F10}", True
                'SendKeys "H", True
              'SendKeys "TM", True
                'Application.Wait (Now + TimeValue("0:00:05"))
                'Application.SendKeys "%s"
                'Application.Wait (Now + TimeValue("0:00:05"))
        
    
    ElseIf Trim(LCase(Cells(3, i + 1))) = "no" Then
    'do nothing
        
    Else: 'for Joint Session Name
            Set OLAppointment = olApp.CreateItem(olAppointmentItem)
            'OLAppointment.MeetingStatus = olMeeting
            Set outNameSpace = olApp.GetNamespace("MAPI")
    'Set outCalendarFolder = outApp.Session.GetDefaultFolder(olFolderCalendar).Parent.Parent.Folders("mysharedmailbox@me.me ").Folders("mysharedmailbox")
    
            OLAppointment.Display
            Set attach = OLAppointment.Attachments
            OLAppointment.Location = "Microsoft Teams Meeting"   
            On Error Resume Next
            OLAppointment.Subject = Cells(27, i + 1).Value 'subject
            OLAppointment.Start = Cells(19, i + 1).Value + Cells(21, i + 1).Value 'start
            OLAppointment.End = Cells(19, i + 1).Value + Cells(23, i + 1).Value 'end
          
            'Mail Body with Greetings
            OLAppointment.Body = "Hi " & Cells(31, i + 1).Value & vbCr _
            & vbCr _
            & Cells(33, i + 1).Value & vbCr

            '=============To_Start===============================================================================
            Dim listArray() As String, x As Integer
            listArray = Split(Cells(7, i + 1), ",")
            For x = LBound(listArray) To UBound(listArray)
                Set Rng = Sheets(Cells(5, i + 1).Value).Range("B7:B" & Sheets(Cells(5, i + 1).Value).Cells(Rows.Count, 2).End(xlUp).Row)
                For Each cellrng In Rng
                    If cellrng = listArray(x) Or cellrng = LCase(listArray(x)) Or cellrng = UCase(listArray(x)) Then
                        If Cells(9, i + 1) = "P" Then
                            OLAppointment.Recipients.Add cellrng.Offset(0, 14).Value
                        Else
                            OLAppointment.Recipients.Add cellrng.Offset(0, 35).Value
                        End If
                        OLAppointment.Save
                    End If
                Next cellrng
            Next x
              '<<<<<<<<<<<<<<<<<<<<<<<<<<To_End>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
            '=============Additional_To_Start=======================================================================
            If Cells(15, i + 1) <> "" Then
                OLAppointment.Recipients.Add Cells(15, i + 1).Value
                OLAppointment.Save
            End If
            '<<<<<<<<<<<<<<<<<<<<<<<<<<Additional_To_End>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
            '=============To_add_Optional=================================================================================
            If Cells(17, i + 1) <> "" Then
                Set optionalAppointment = OLAppointment.Recipients.Add(Cells(17, i + 1).Value)
                optionalAppointment.Type = 2
            End If
            'on Behalf
            If Cells(25, i + 1) <> "" Then
                sentMailItem.SentOnBehalfOfName = Cells(25, i + 1).Value
            
            End If
            '<<<<<<<<<<<<<<<<<<<<<<<<<<To_End>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
            '============Attachment_Start==========
            If Cells(29, i + 1) <> "" Then
                strFolderPath = Cells(29, i + 1).Value
                strFileName = Dir(strFolderPath)
                While Len(strFileName) > 0
                    attach.Add (strFolderPath & strFileName)
                    strFileName = Dir
                Wend
            End If
            'Application.Wait (Now + TimeValue("0:00:01"))
            OLAppointment.Send
            Application.Wait (Now + TimeValue("0:00:05"))
            '<<<<<<<<<<<<<<<<<<<<<<<<<<Attachment_End>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
            'MsgBox "Invitation " & i & " have been Completed"
            
            'SendKeys "{F10}", True
            'SendKeys "H", True
            'SendKeys "TM", True
            'Application.Wait (Now + TimeValue("0:00:05"))
            'Application.SendKeys "%s"
            'Application.Wait (Now + TimeValue("0:00:05"))
                
                SendKeys "{F10}", True
            SendKeys "H", True
            SendKeys "i", True
            Application.Wait (Now + TimeValue("0:00:2"))
            
                     SendKeys "{F10}", True
            SendKeys "H", True
            SendKeys "TM", True
            SendKeys "{F10}", True
            SendKeys "{8}", True
            SendKeys "{3}", True
            
             Application.Wait (Now + TimeValue("0:00:2"))
            SendKeys "{F10}", True
             SendKeys "H", True
            SendKeys "AR", True
            SendKeys "T", True
            Application.Wait (Now + TimeValue("0:00:10"))
    
    End If
Next i
 Application.Wait (Now + TimeValue("0:00:05"))

MsgBox "Invitations have been Completed."
        
Set OLAppointment = Nothing
Set OLNS = Nothing
Set olApp = Nothing
Set Rng = Nothing
End If
End Sub