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

Question

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

Answer 1

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.