forcer outlook à s'ouvrir pour envoit Mail

Bonjour à tous
j'ai une macro bidouillée pour envoyer la feuille active (sans ces macro) par outlook.
si outlook est ouvert tous marche
si outlook n'est pas lancé, tous ce passe bien, sauf que le mail n'est pas envoyer
la procédure ce passe comme si outlook était ouvert, j'ai laissé .Display pour afficher la fenêtre nouveau message outlook
il s'affiche bien, je fais envoyer, il part bien
mais résultat pas de mail dans boite de réception

comment forcer outlook à s'ouvrir

Merci pour votre aide

CODE:
Sub Mail()
Dim I As Integer
Dim FileExtStr, MailCC, MailTo As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
'Recherche la liste des destinataire pour mailCC
For I = 4 To 54
If Sheets("ListeMail").Cells(I, 4) = "AA" Then
MailTo = MailTo & Sheets("ListeMail").Cells(I, 3) & ";"
End If
Next I
'Recherche la liste des destinataire pour mailCC
For I = 4 To 54
If Sheets("ListeMail").Cells(I, 4) = "CC" Then
MailCC = MailCC & Sheets("ListeMail").Cells(I, 3) & ";"
End If
Next I
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Sourcewb = ActiveWorkbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
With Destwb
If Val(Application.Version) < 12 Then

FileExtStr = ".xls": FileFormatNum = -4143
Else
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Votre réponse est NON dans la boîte de dialogue de sécurité"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
TempFilePath = Environ$("temp") & "\"
TempFileName = Sourcewb.Name & " " & Format(Now, "dd-mmm-yyyy")

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
ActiveSheet.Shapes("CommandButton1").Delete
ActiveSheet.Shapes("CommandButton2").Delete
End With
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next

With OutMail
.To = MailTo ' Destinataire
.CC = MailCC ' Copie
.BCC = ""
.Subject = "test" & " - " & Format(Now, "dd-mmm-yyyy ")
.Body = "mon message"
.Attachments.Add Destwb.FullName
.Display
End With

On Error GoTo 0
.Close savechanges:=False
End With

Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub