How to wait until e-mail is sent and window is closed in Outlook VBA?

Question

My VBA code opens an e-mail template and should copy the email content into an appointment after editing and sending the e-mail.

The problem is that the appointment opens before the e-mail is sent, and the unedited e-mail content is inserted into the appointment. (if I remove the while loop)

How can I wait for sending the e-mail and closing its window?

Error: Outlook freezes or it displays the error:

runtime error '-2147221238 (8004010a)': element moved....

Public Sub Fooo()
Dim items As Outlook.items
Dim Item As Object

Set items = Application.ActiveExplorer.CurrentFolder.items

Set Item = items.Add("IPM.Note.My Template Mail")
Item.SentOnBehalfOfName = "foo@bar.com"
Item.Display

While Item.Sent = False
Wend

CreateAppointment MyMail:=Item

End Sub

Answer 1

You'll have to modify a bit your CreateAppointment sub,
but use a variable to store the content of the mail before sending it and then pass it to your sub!

Public Sub Fooo()
Dim items As Outlook.items
Dim Item As Object
Dim ItmContent As String

Set items = Application.ActiveExplorer.CurrentFolder.items

Set Item = items.Add("IPM.Note.My Template Mail")

With Item
    .SentOnBehalfOfName = "foo@bar.com"
    .Display True

    Do
        ItmContent = .Body 'Or other property that you use in CreateAppointment
        DoEvents
    Loop Until Item Is Nothing
End With 'Item

CreateAppointment ItmContent

End Sub

Working solution with error handling :

Public Sub Fooo()
Dim items As Outlook.items
Dim Item As Object
Dim ItmContent As String

Set items = Application.ActiveExplorer.CurrentFolder.items

Set Item = items.Add("IPM.Note.My Template Mail")

Item.SentOnBehalfOfName = "foo@bar.com"
Item.Display

On Error GoTo MailSent
    Do
        ItmContent = Item.Body 'Or other property that you use in CreateAppointment
        DoEvents
    Loop Until Item Is Nothing
On Error GoTo 0


DoEvents
AfterSend:
    'Debug.Print ItmContent
    CreateAppointment ItmContent
    Exit Sub
MailSent:
    If Err.Number <> -2147221238 Then
        Debug.Print Err.Number & vbCrLf & Err.Description
        Exit Sub
    Else
        Resume AfterSend
    End If
End Sub