Tâches Outlook. message d'avertissement

Bonjour,

J'ai créé une macro excel qui génère et envoie des tâches depuis une boîte commune.

Afin de ne pas surcharger cette boite, j'ai désactivé dans les options l'enregistrement automatique d'une copie.

Bien sur, lors de l'envoi de la tâche, un message d'avertissement apparaît m'informant qu'aucune copie n'est enregistrée. Je me suis débarasser du problem en utilisant des SendKeys (fin de la deuxième macro). Jusque la tout bien.

Je transmits le fichier à un collègue... les sendkeys ne fonctionnent pas... (bien sur).

Question: est-il possible de désactiver ces messages ou qu'est-ce qui est faux?

Merci

Damien

Préparation:

Sub envois_tasks()
Dim dest As String
Dim ech As String
Dim i As Integer
Dim enonce As String
Dim prenom As String
Dim ou As Range
Dim result As Range
Dim no As String
Dim int_ext As String
Dim titre As String

i = 5

no = Sheets("En cours").Range("A" & i).Value
Set ou = Sheets("En cours 2").Columns(1)
Do While no <> ""
    Set result = ou.Cells.Find(What:=no)
    If result Is Nothing Then
        For u = 7 To Sheets("En cours 2").Range("L2").Value
            If u <> 20 And Sheets("En cours").Cells(i, u).Interior.ColorIndex = 6 Then
                Sheets("En cours 2").Range("I2").Value = Cells(4, u).Value
                titre = Sheets("En cours").Range("E" & i).Value
                Sheets("En cours 2").Range("P2").Value = titre
                Task.titre = Sheets("En cours 2").Range("Q2").Value
                prenom = Sheets("En cours 2").Range("J2").Value
                dest = Sheets("En cours 2").Range("K2").Value
                ech = Sheets("En cours").Range("D" & i).Value
                enonce = Sheets("En cours").Range("E" & i).Value
                Mess = "Bonjour " & prenom & "," & Chr(13) & Chr(13)
                If Sheets("En cours").Range("B" & i).Value = "x" Then int_ext = " interne" Else int_ext = " externe"
                Mess = Mess & "Une nouvelle tâche" & int_ext & " en suspens vous a été attribuée avec pour délai le " & ech & Chr(13) & Chr(13)
                Mess = Mess & "L'enoncé de celle-ci est:" & Chr(13) & Chr(13)
                Mess = Mess & enonce & Chr(13) & Chr(13)
                Mess = Mess & "Meilleures salutations," & Chr(13) & Chr(13)
                Mess = Mess & "Le team admin"
                Call SendMail(dest, ech)
            End If
        Next
    End If
    i = i + 1
    no = Sheets("En cours").Range("A" & i).Value
Loop
Sheets("En cours").Activate
End Sub

Envoi:

Sub SendMail(dest As String, Echeance As String)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim i As Integer
    Dim nom As String
    Dim compte As Integer
    Dim myOlApp As Outlook.Application
    Dim myItem As Outlook.TaskItem
    Dim myDelegate As Outlook.Recipient
    Set myOlApp = New Outlook.Application

    For i = 1 To myOlApp.Session.Folders.Count
        If myOlApp.Session.Folders.Item(i) = "_F_VTG-LBA ALCG-RAVEVAC" Then
            compte = i
            Exit For
        End If
    Next i

    Set myItem = myOlApp.Session.Folders.Item(compte).Items.Add(olTaskItem)

'    Set myItem = myOlApp.Session.Folders.Item(3).Items.Add(olTaskItem)
    myItem.Assign
    Set myDelegate = myItem.Recipients.Add(dest)

    myDelegate.Resolve
    If myDelegate.Resolved Then
        myItem.Subject = Task.titre
        myItem.Body = Task.Mess
        myItem.DueDate = Echeance

        myItem.StartDate = Now
        myItem.ReminderTime = True 'Rappel
        myItem.Display
        Application.DisplayAlerts = False
        myItem.Send

'ou

        Application.Wait (Now + TimeValue("0:00:03"))
        Application.SendKeys "^~" 'presses send as a send key
        Application.Wait (Now + TimeValue("0:00:03"))
        SendKeys "TAB", True
        SendKeys "{ENTER}", True
        i = 0
    End If

'ou

    Do Until i = 11
        i = i + 1
    Loop
    SendKeys "{ENTER}", True
    SendKeys "{ENTER}", True

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub