Discussion :

[graphikris]

Bonjour,

Afin de remercier Daniel C., qui m'a beaucoup aidé, j'ai décidé de mettre en ligne un code permettant d'envoyer un mailing le premier jour du mois ouvré à plus d'une centaine de destinataires par le biais de Outlook 2003 (ou +).

Ce code a été testé sous Xl 2003 donc utilisable sur les versions supérieures.

En fonction de vos désirs, ce code est modifiable. Vous pourrez soit envoyer le mail à l'ouverture de Excel soit envoyer un mail par déclenchement d'une macro.

Code à insérer dans Worbook (Open) pour un déclenchement automatique le 1er jour ouvré du mois.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
 ' Envoi de mails 1er jour du mois ouvré
 If [Accueil!A2] = "" Then [Accueil!A2] = 1
    If Month([Accueil!A2]) <> Month(Date) Then
        [Accueil!A2] = Date
' déclenchement macro
        Envoi_Mail_Visite_medicale_depassee
End If

Explication :
Vous allez créer une feuille que vous nommerez "Accueil" en cellule A2, vous taperez ceci : =aujourdhui() ou à défaut laissez cette cellule vierge.
Le code ci dessus va déclencher la macro suivante : Envoi_Mail_Visite_medicale_depassee()
Vous remplacerez ma macro par celle que vous désirerez déclencher.

Ensuite copier ce code dans un nouveau module (Alt + F11) _ Insertion / Module :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
115
116
117
118
119
120
121
122
123
124
125
126
127
Sub Envoi_Mail()
 
Dim olapp As Outlook.Application
Dim malist, Count, Envoi
Dim I 
            '-------Contrôler dans Visual Basic/Outils/Références/que Microsoft Outlook --,- Object Librairy est bien coché
 
Dim Sujet As String
Dim Corps As String
 
Sheets("Envoi Mail").Select
 
With Sheets("Envoi Mail")
 
' Effacement des données sur feuille Matrice Mail
    'Sheets("Matrice Mail").Select
     '   Cells.Select
      '  Application.CutCopyMode = False
       ' Selection.Delete Shift:=xlUp
        'Range("A1").Select
 
 
        'Boucle
     Do
        'Boite de dialogue demandant le sujet du mail
        Sujet = InputBox("Veuillez saisir le sujet de votre @mail :" & Chr$(13) & "ATTENTION : la saisie est obligatoire.", "Sujet")
        'si sujet non saisi alors retour jusqu a saisi
        If Sujet = "" Then
    MsgBox "Vous n'avez pas saisi de sujet." _
     & "La zone est obligatoire", vbExclamation
     End If
     Loop Until Sujet <> ""  'Fin de boucle
 
 
     'Boucle
     Do
     'Boite de dialogue demandant le corps du message
        Corps = InputBox("Veuillez saisir le corps de votre message : " & Chr$(13) & "ATTENTION : la saisie est obligatoire.", "Corps")
      'si Corps non saisi alors retour jusqu a saisi
      If Corps = "" Then
     MsgBox "Vous n'avez pas saisi de texte pour le corps de votre message." _
     & "La zone est obligatoire", vbExclamation
     End If
    Loop Until Corps <> ""  ' Fin de boucle
 
 
 
    Dim adresse(1 To 150)
                '----------------------Création de la liste d'adresses mail contenus de la ligne 2 à 151
    Set malist = Sheets("Envoi Mail").Range("A2:A151")
    Count = 1
    For Each Envoi In malist
    If Len(Envoi) Then adresse(Count) = Envoi: Count = Count + 1
    Next
                '----------------------Copie de la liste d'adresse dans une cellule vide exemple H1
    For I = 1 To 150
        If adresse(I) = "" Then Exit For
        If adresse(I) Like "*@*" Then .[H1] = .[H1] & ";" & adresse(I)
    Next I
 
    '-------adresse du répertoire ou sera enregistré le fichier
    ' l adresse ci dessous correspond au repertoire racine du fichier Excel dans lequel on bosse
        AdresseRépertoire = ActiveWorkbook.Path
' ou autre destination, ici chemin disque Y
    'AdresseRépertoire = "Y:\TRAVAIL\Transfert Svg Mail"
                '---------------------copie de la feuille à envoyer
    Application.DisplayAlerts = False
    Sheets("Matrice Mail").Copy
                '---------------------Nom du fichier à envoyer
    Dim NameXls As String
 
     Do
        'Boite de dialogue demandant le Nom du fichier à envoyer
        NameXls = InputBox("Veuillez saisir le nom du fichier à envoyer :" & Chr$(13) & "ATTENTION : la saisie est obligatoire.", "Nom du fichier à envoyer")
        'si NameXls non saisi alors retour jusqu a saisi
        If NameXls = "" Then
    MsgBox "Vous n'avez pas saisi de nom pour le fichier à envoyer." _
     & "La zone est obligatoire", vbExclamation
     End If
     Loop Until NameXls <> ""
 
 
    ActiveWorkbook.SaveAs AdresseRépertoire & "\" & NameXls & ".xls"
    ActiveWindow.Close
                '---------------------Envoi par mail
    Sheets("Envoi Mail").Select
    .Range("H1").Select
                '---------------------contrôle la validité ou la présence d'adresse mail en H1
    Dim msg As MailItem
    Set olapp = New Outlook.Application
    Set msg = olapp.CreateItem(olMailItem)
    msg.To = .Range("H1").Value 'Adresse de la cellule contenant la liste des adresses mails
                '--------------------Saisir le sujet de l'envoi dans boite dialogue
    msg.Subject = Sujet  'Sujet étant la InputBox
                '---------------------ou Saisir sujet du message à la place des guillemets.
'msg.subject = "mettre ici le sujet du message"
 
                '---------------------Saisie du corps du message dans InputBox
     msg.Body = Corps
                ' ou Saisir corps du msg à la place des guillemets
'msg.Body = "mettre ici le corps du message"
 
                '---------------------Adresse de la pièce jointe
    msg.Attachments.Add Source:=AdresseRépertoire & "\" & NameXls & ".xls"
    msg.Display
    msg.Send
                '---------------------effacement de la liste d'envoi
    [H1].ClearContents
    Application.ScreenUpdating = True
 
    [A2:A151].ClearContents
    Range("A1").Select    
End With
 
 
 
 rep = MsgBox("Votre mail a été transmis aux différents destintaires à " & Time, vbYes + vbInformation, "Transmission de mail / Application développée par Graphikris.")
    Select Case MsgBox("Désirez-vous effectuer un autre mailing ?", vbYesNo, "Application développée par Graphikris.")
    Case vbYes
        'procédure si click sur Oui
    Sheets("Envoi Mail").Select
    Case vbNo
        'procédure si click sur Non
    Sheets("Accueil").Select
End Select
 
End Sub

Explication :
Créez 2 feuilles nommées : Envoi mail et Matrice mail

Dans Microsoft Visual Basic (Alt + F11) assurez vous que l'option suivante soit cochée : Allez dans Outils / Références et cochez : Microsoft Outlook 11.0 Object Library.

ATTENTION pour que tout celà puisse fonctionner, il faut absolument que dans la macro qui se déclenche à l'ouverture d'Excel dans Worbook, que celle ci aille copier vos destinataires en feuille "Envoi Mail" de la cellule A2 à A151 Maxi. Sinon la macro ne fonctionnera pas puis vous n'aurez aucun destinataire pour votre mailing.

Afin de vous éviter de vous prendre la tête, je vous joins un fichier que vous adapterez selon vos besoins.

La première fois que vous l'utiliserez, le mailing se déclenchera meme si nous ne sommes pas le 1er du mois car en A2, je n'ai pas saisi de date et la macro ne fonctionnera pas car il n'y a pas de destinataire.

[graphikris]

Bonjour,
Je remarque qu'en 1 heure, environ 30 visites mais aucune réponse au sondage.
N'hésitez pas, une critique est toujours bonne à prendre afin de s'améliorer et un compliment fait toujours plaisir.

[abeaupere]

Bonjour,

Pourriez vous m'envoyer votre fichier

Merci

[patricktoulon]

Bonjour

Perso je préfère utiliser le CDO plutôt que Outlook mais bon ......

en ce qui concerne ton code il est trop personnel (adapter a TON BESOIN!!!)


une contribution doit être le plus générique possible

exemple séparer les conditions dans une sub différente ainsi que la fabrication du corps du message et l'envoie

car pour les autres seuls ces deux derniers éléments sont valables

mais +1 pour le boulot