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

Question

I can send the resulting meeting request and it is accepted by the recipient as a meeting request when I run the following code with.display and the Outlook Appointment is formed correctly (shared calendar, recipients, time, etc.). The recipient receives a meeting cancellation for a meeting that doesn't exist, yet everything seems to work fine if I change.display to.send.

Could someone please explain 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, but .send doesn't

Answer 1

Because an inappropriate sender will be used, you cannot directly transfer objects from a shared folder. When you need to send anything on behalf of someone else, you can use the SentOnBehalfOfName property for mail items but not appointments.