[XL-2003] Message Outlook ne s'envoi pas

J'utilise un code VBA pour l'envoi de message Outlook à partir d'un classeur Excel, après avoir ajouté une liste de destinataires et rattachement d'un fichier Excel.
Ce code ne marche pas à tous les coups ! (quand j'utilise ma propre adresse émail, ça marche ); une fois lancé, rien ne se passe au niveau d'Outlook; aucun message d'erreur n'est affiché;
Est ce que quelqu'un peut me renseigner sur l'anomalie éventuelle
Merci

Ci-joint le code et le classeur Excel à partir duquel je lance le code et qui comprend les informations lues ( destinataires et autre)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
Sub envoyer_rapports()
 
 
' envoyer_rapports Macro
' Macro enregistrée le 28/12/2005 par Redouane Rouissam
 
' Lance une session Microsoft Outlook
Set appOutlook = New Outlook.Application
' Crée un nouveau message
 
Dim Date_Rapport As String
Dim Nom_Fichier As String
Dim Repertoire As String
Dim Destinataire As String
Dim Réponse As Integer
i = 1
 
Range("C24").Select
Repertoire = ActiveCell.Value
 
Réponse = MsgBox("Est ce que vous confirmer l'envoi des rapports clients arrêtés", 4 + 32 + 256 + 0, "Envoi des rapports Clients")
 
If Réponse = vbNo Then
 
    MsgBox "Vous avez annulé l'envoi des rapports clients"
    Exit Sub
Else
    MsgBox "Vous avez lancé l'envoi des rapports clients"
 
End If
 
Application.DisplayAlerts = False
Application.ScreenUpdating = False
 
Range("C8").Select
 
Do While ActiveCell.Value <> ""
 
    If ActiveCell.Value = "Oui" Then
 
            ActiveCell.Offset(0, 1).Select
 
            Nom_Fichier = ActiveCell.Value
 
 
            ' la macro ouvre le fichier de base en mode lecture
 
            Workbooks.Open Filename:= _
                Repertoire & "\" & Nom_Fichier, ReadOnly:=True
 
            Date_Rapport = Format(Worksheets("Date Rapport").Range("B13").Value, "dd_mm_yyyy")
 
            ActiveWorkbook.Close
 
            On Error Resume Next
 
            Set Message = appOutlook.CreateItem(olMailItem)
 
            On Error Resume Next
 
            With Message
            ' Titre, Texte, Destinataires, Pièces jointes du message
            .Subject = "Rapport mensuel Comptes Clients" & "_" & Nom_Fichier & _
                          "_" & Date_Rapport
            .Body = "Bonjour," & Chr(13) & "vous trouverez ci-joint le rapport comptes clients du mois écoulé." _
            & Chr(13) & "Ce rapport comprend :" _
            & Chr(13) & "- la proposition d'objectifs recouvrement du mois courant, " _
            & Chr(13) & "- la balance Risque résumée, " _
            & Chr(13) & "- la balance détaillée, " _
            & Chr(13) & "- le délai client de fin de mois, " _
            & Chr(13) & "- le délai client moyen des 12 derniers mois, " _
            & Chr(13) & "- le taux d'impayés, " _
            & Chr(13) & "- et le détail des impayés par mois par client. " _
            & Chr(13) & "" _
            & "Nous vous prions de nous remettre vos propositions d'objectifs avant le 10 du mois courant, en utilisant la feuille 'Proposition d'objectifs', et en expliquant l'écart entre solde et objectif." _
            & Chr(13) & "" & Chr(13) & "Sincères salutations" _
            & Chr(13) & "" & "Comptabilité Clients"
 
            .BodyFormat = olformatHTML
            ActiveCell.Offset(0, 1).Select
 
                Do While ActiveCell.Value <> ""
                    Destinataire = ActiveCell.Value
                    .Recipients.Add (Destinataire)
                    ActiveCell.Offset(0, 1).Select
                    i = i + 1
                Loop
 
            .Attachments.Add Repertoire & "\" & "Reportings\" & Date_Rapport & "\" & Nom_Fichier & _
                          "_" & Date_Rapport & ".xls"
            .Send
            End With
 
            ActiveCell.Offset(1, -i).Select
 
    Else
 
    ActiveCell.Offset(1, 0).Select
 
    End If
 
Loop
 
' Quitte l'application Outlook
'appOutlook.Quit
 
' Réinitialise l'objet
Set appOutlook = Nothing
 
Application.ScreenUpdating = True
 
MsgBox "Traitement terminé"
 
End Sub