probleme d'envoi d'un mail en vba

Version imprimable

Bonjour,

Mon code bloque sur mon monmessage.to pouvez vous m'indiquez pourquoi ?

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
 
Dim MonOutlook As Object
Dim MonMessage As Object
 
Set MonOutlook = CreateObject("Outlook.Application")
Set MonMessage = MonOutlook.CreateItem(0)
 
'corps du  message
 
'Message
Message_Mail = "Bonjour," _
 & Chr(10) _
  & Chr(10) & "Test" _
 & Chr(10) & Chr(10) _
 & Chr(10) & Chr(10) & "Cordialement " _
 & Chr(10) & Chr(10) 
 
 
cpt = Sheets("PARAMETRES").Cells(Rows.Count, 10).End(xlUp).Row
 
For L = 2 To cpt
If Sheets("PARAMETRES").Cells(L, 13) = "A FAIRE" Then GoTo line1 Else GoTo line2
line1:
Application.Wait Now + TimeValue("0:00:05")
'variable
'Piece jointe
REP_PJ = Sheets("PARAMETRES").Range("F6")
FIC_PJ = Sheets("PARAMETRES").Cells(L, 10)
CHEMIN_PJ = REP_PJ & FIC_PJ
'liste
NOM = Sheets("PARAMETRES").Cells(L, 8)
Set a = Sheets("PARAMETRES").Range("A:A").Find(NOM, lookat:=xlWhole)
lig = a.Row
LISTE_A = Sheets("PARAMETRES").Cells(lig, 2)
LISTE_CC = Sheets("PARAMETRES").Cells(lig, 3)
LISTE_CCI = Sheets("PARAMETRES").Cells(lig, 4)
 
'envoi
MonMessage.to = LISTE_A
MonMessage.CC = LISTE_CC
MonMessage.BCC = LISTE_CCI
MonMessage.Attachments.Add CHEMIN_PJ
MonMessage.Subject = "test envoi"
MonMessage.Body = Message_Mail
MonMessage.Send
Set MonOutlook = Nothing
Sheets("PARAMETRES").Cells(L, 13) = "Fait le  " & Now()
line2:
Next

J'ai environ 60 mails a envoyer.

Merci pour votre aide

06/04/2019, 15h23
laurent27530

Le fait de ne pas avoir de copie (CC) ou copie caché (CCI) pour certains peux t il impacter le script ?

Il bloque au bout de 2 envois

Message d'erreur erreur -2147221238 (8004010a) l'élément a été déplacé

Il y a un souci je pense sur le fait que j'ai mis une boucle

Bonjour,

j'ai modifié le code comme ci dessous cela fonctionne

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
Sub D_ENVOI_MAIL()

Dim olApp As Outlook.Application
Dim olMail As MailItem
Dim Ficjoint As String
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)
Dim LISTE_A, LISTE_CC, LISTE_CCI, Message_MAIL, Titre As String


'Message_Mail = "Bonjour," _
 & Chr(10) _
  & Chr(10) & "Test" _
 & Chr(10) & Chr(10) _
 & Chr(10) & Chr(10) & "Cordialement " _
 & Chr(10) & Chr(10) 
 
cpt = Sheets("PARAMETRES").Cells(Rows.Count, 10).End(xlUp).Row
 
For L = 2 To cpt
Set olMail = olApp.CreateItem(olMailItem)
If Sheets("PARAMETRES").Cells(L, 13) = "A FAIRE" Then GoTo line1 Else GoTo line2
line1:
Application.Wait Now + TimeValue("0:00:05")
'variable
'Piece jointe
REP_PJ = Sheets("PARAMETRES").Range("F6")
FIC_pj = Sheets("PARAMETRES").Cells(L, 10)
CHEMIN_PJ = REP_PJ & FIC_pj
'titre
Titre = Replace(FIC_pj, ".xlsx", "")

'récupération de la  bonne liste d'envoi
NOM = Sheets("PARAMETRES").Cells(L, 8)
Set a = Sheets("PARAMETRES").Range("A:A").Find(NOM, lookat:=xlWhole)
lig = a.Row
LISTE_A = Sheets("PARAMETRES").Cells(lig, 2)
LISTE_CC = Sheets("PARAMETRES").Cells(lig, 3)
LISTE_CCI = Sheets("PARAMETRES").Cells(lig, 4)

'envoi du  mail 
olMail.To = LISTE_A
olMail.CC = LISTE_CC
olMail.BCC = LISTE_CCI
olMail.Attachments.Add CHEMIN_PJ
olMail.Subject = Titre
olMail.Body = Message_MAIL
olMail.Send
Set olMail = Nothing
Sheets("PARAMETRES").Cells(L, 13) = "Fait le  " & Now()
line2:
Next

End Sub