[XL-2010] Envoi mail via Outlook depuis excel en VBA

Bonjour,

je dois envoyer un mailing avec des infos issues d'une feuille excel.
Les addresses des destinataires ainsi que d'autres infos sont des contenus de cellules.
Le pb c'est que mon code fonctione une seule fois ( un mail envoyé ) puis j'ai l'erreur : 91 Variable d'objet ou variable de bloc with non définie.
Ci-dessous mon code
--------------------------------------------------------------------------------

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
 
Sub Mailing()
 
    Dim appOutlook As Outlook.Application
    Set appOutlook = CreateObject("outlook.application")
 
    Dim oMail As Outlook.MailItem
    Set oMail = appOutlook.CreateItem(olMailItem)
 
    Dim EMailSendTo As String, EMailCCTo As String, EMailBCCTo As String
 
 
    Dim cpt As String
    Dim nblignes As Long
 
 
 
     cpt = 0
    'Compte le nbre de lignes pour le nbre d'enregistrements
     ActiveWorkbook.Sheets("Echeances_contrats").Select
     Range("O2").Select
     nblignes = Range("O2").CurrentRegion.Rows.Count - 1
 
     Do While cpt < nblignes
 
     EMailSendTo = ActiveCell.Offset(cpt, 0).Value
     EMailCCTo = ActiveCell.Offset(cpt, 2).Value
 
 
     MsgBox cpt & nblignes  ' affichage test
     MsgBox EMailSendTo    ' affichage test
     MsgBox EMailCCTo       ' affichage test
 
 
        With oMail
        .To = EMailSendTo
        .CC = EMailCCTo
 
        .Subject = "AVIS DE FIN DE CONTRAT"
        .BodyFormat = olFormatHTML
        .Body = "A l'attention du Responsable Informatique" & Chr(13) & "Cher(e) client(e) ,"
        .Send
 
         Set oMail = Nothing
 
        End With
 
    cpt = cpt + 1
 
 
    Loop
 
End Sub

Sub Mailing() Dim appOutlook As Outlook.Application Dim oMail As Outlook.MailItem Dim EMailSendTo As String, EMailCCTo As String, EMailBCCTo As String Dim cpt As String Dim nblignes As Long cpt = 0 'Compte le nbre de lignes pour le nbre d'enregistrements ActiveWorkbook.Sheets("Echeances_contrats").Select Range("O2").Select nblignes = Range("O2").CurrentRegion.Rows.Count - 1 Do While cpt < nblignes EMailSendTo = ActiveCell.Offset(cpt, 0).Value EMailCCTo = ActiveCell.Offset(cpt, 2).Value Set appOutlook = CreateObject("outlook.application") Set oMail = appOutlook.CreateItem(olMailItem) With oMail .To = EMailSendTo .CC = EMailCCTo .Subject = "AVIS DE FIN DE CONTRAT" .BodyFormat = olFormatHTML .Body = "A l'attention du Responsable Informatique" & Chr(13) & "Cher(e) client(e) ," & Chr(13) & "Suivant nos informations et sauf erreur, votre Contrat de maintenance numéro: " & "" & ActiveCell.Offset(cpt, -3).Value .Send End With Set oMail = Nothing Set appOutlook = Nothing cpt = cpt + 1 Loop End Sub