Excel VBA creating a new Outlook appointment results in a cancelled appointment

When I run the following code with .display, the Outlook Appointment gets created in the correct way (shared calendar, recipients, time etc) and I can send the resultant meeting request and it is received by the recipient as a meeting request. However, if I change .display to .send, everything appears to work OK, but the recipient recieves a meeting cancellation (for a meeting that doesn't exist!).

Can anyone point out where I'm going wrong?

Sub CreateMeetings()

Dim olApp As Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim r As Long
Dim oApp As Object
Dim oNameSpace As Namespace
Dim myCalendar As Object
Dim OLNS As Object
Const olAppointmentItem As Long = 1
Dim OLAppointment As Object
Dim MeetingKey As String
Dim datenum As Long
Dim smtprecipient As String
Dim MeetingKeyString As String
Dim emailchk As Long



Set oApp = New Outlook.Application
Set olApp = CreateObject("Outlook.Application")

On Error Resume Next


Set olApp = GetObject("", "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Outlook is not available!"
Exit Sub
End If
End If
'get default user email address
smtprecipient = GetSMTPEmailAddress

'check to see if email address returned is a valid one
emailchk = InStr(1, smtprecipient, "@company_domain.co.uk")
'get a valid email address if the check fails
If emailchk = 0 Then
    smtprecipient = InputBox("Enter your Company Email Address", "Email Address Required")
End If


Set OLNS = olApp.GetNamespace("MAPI")
    OLNS.Logon
    Dim objRec As Outlook.Recipient
    Set objRec = OLNS.CreateRecipient(smtprecipient)
    objRec.Resolve
    Set myCalendar = OLNS.GetSharedDefaultFolder(objRec, olFolderCalendar).Folders("Frontline")
    Set OLAppointment = myCalendar.Items.Add(olAppointmentItem)
    Dim i As Long, Schedsht As Worksheet
    Set Schedsht = Worksheets("Shift Allocation")
    Sheets("Shift Allocation").Select

For i = 6 To Range("A" & Rows.Count).End(xlUp).Row
If Schedsht.Range("T" & i).Value = "" And Schedsht.Range("S" & i).Value = True Then
datenum = Date + (Time * 10000) + i
MeetingKeyString = Schedsht.Range("Z" & i).Value
MeetingKey = "S" & CStr(datenum) & Schedsht.Range("B" & i).Value
    With OLAppointment
            .Subject = "Shift" & " (" & MeetingKey & ")"
            .RequiredAttendees = Schedsht.Range("I" & i).Value & ";" & Schedsht.Range("J" & i).Value _
             & ";" & Schedsht.Range("K" & i).Value
            .Start = Schedsht.Range("D" & i).Value
            .End = Schedsht.Range("E" & i).Value
            .Location = Schedsht.Range("C" & i).Value
            .ReminderMinutesBeforeStart = 720
            .MeetingStatus = olMeeting
            
            .Body = Schedsht.Range("M" & i).Value & vbCrLf & vbCrLf & "Welcome to our new Rota system. For details on how this all works, _
            please go to xxxx."
           .Display
            '.Send
        On Error GoTo 0
    End With

Schedsht.Range("T" & i).Value = True
Schedsht.Range("Y" & i).Value = MeetingKey
Schedsht.Range("AA" & i).Value = MeetingKeyString
Else

End If

Next i
 
MsgBox "All Shifts Processed"
Set olAppItem = Nothing
Set olApp = Nothing
Set oFolder = Nothing

Exit Sub

Set olAppItem = Nothing
Set olApp = Nothing
Set oFolder = Nothing
End Sub

See above. changing to .display works OK, .send doesn't

You can not send items from a shared folder explicitly because an incorrect sender will be used. You can use the SentOnBehalfOfName property for mail items, but not appointments, when you need to send items on behalf of another person.

Call the Save method before the Send one to submit the item from a shared folder.