Macro envoi d'un mail outlook via liste excel avec pièce jointe différente pour chaque destinataire

Version imprimable

Bonjour,

Je cherche à savoir comment automatiser l'envoi de mails via une liste de contacts Excel (comportant plusieurs colonnes dont le nom, le prénom, l'adresse et surtout le mail) avec l'envoi d'une pièce jointe différente pour chaque destinataire. Toutes ces pièces jointes seraient stockées dans un dossier spécial.

Après quelques recherches j'ai réussi à trouver cette macro et la modifier pour qu'elle corresponde à mes besoins. Grâce à elle j'arrive à envoyer un mail à tous les destinataires de ma liste, en y ajoutant une pièce jointe spécifique mais cependant unique et non différente comme je le voudrais.

Je voudrais donc savoir comment modifier mon code pour que la macro modifie la pièce jointe pour chaque destinataire. Une des façons de faire à laquelle je pensais c'est puiser le Nom et Prénom du destinataire dans la liste Excel des contacts et les utiliser pour retrouver la pièce jointe correspondante (qui comportera en intitulé le Nom et Prénom du destinataire), mais je n'ai aucune idée de comment le mettre en oeuvre, parce que je n'ai que très peu de connaissances en code vu que ce n'est pas mon métier, même si j'arrive à me débrouiller.

Sur ce forum j'ai trouvé une discussion qui parle de ça et où un utilisateur spécifie qu'il utilise une boîte de dialogue lui permettant de choisir la pièce jointe avant l'envoi du mail, ça pourrait être une solution mais moins pratique que la sélection automatique. (lien de la discussion : https://www.developpez.net/forums/d1...er-envoyer-pj/)
Cependant je ne sais pas comment intégrer ce module à ma macro.

Voici donc le code la macro que j'utilise pour l'instant, en attendant de la modifier pour qu'elle réponde à mes besoins :
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 Sub Sample() 'Setting up the Excel variables. Dim olApp As Object Dim olMailItm As Object Dim iCounter As Integer Dim Dest As Variant Dim SDest As String 'Create the Outlook application and the empty email. Set olApp = CreateObject("Outlook.Application") Set olMailItm = olApp.CreateItem(0) 'Using the email, add multiple recipients, using a list of addresses in column A. With olMailItm SDest = "" For iCounter = 1 To WorksheetFunction.CountA(Columns(1)) If SDest = "" Then SDest = Cells(iCounter, 1).Value Else SDest = SDest & ";" & Cells(iCounter, 1).Value End If Next iCounter 'Do additional formatting on the BCC and Subject lines, add the body text from the spreadsheet, and send. .BCC = SDest .Subject = "Sujet" .Body = ActiveSheet.TextBoxes(1).Text .Importance = olImportanceHigh .Attachments.Add "Chemin du fichier" .Send End With 'Clean up the Outlook application. Set olMailItm = Nothing Set olApp = Nothing End Sub
Je vous remercie d'avance pour vos réponses, je vais continuer de chercher en attendant !

Bonne journée,

Bonjour,

Ci-dessous un macro qui envoie des mails avec pj différente a chaque fois
Se base sur un tableau avec en colonne A le sujet du mail, en B le corps du mail, en C l'adresse mail du destinataire, et en D le nom de la PJ(avec l'adresse complète: d:\chemin\monpdf.pdf par exemple)

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
sub mail
Dim ObjOutlook As Object, txt As String, cel As Range
Set ObjOutlook = CreateObject("outlook.application")
For i = 2 To 1001
 
    Set oBjMail = ObjOutlook.CreateItem(olMailItem)
        With oBjMail
            .Display
            .To = cells(i,3).value
            .CC = "" 'copie
            .Subject = cells(i,1).value 'titre
            .Body =cells(i,2).value 'message
            'pièces jointes
            .Attachments.Add cells(i,4).value
 
            'au choix l'une des trois lignes suivantes
            .Display 'pour afficher le message dans outlook
            '.Save 'pour le sauver dans les brouillons
            '.send 'pour l'envoyer
 
        End With
 
Next i
End Sub

21/10/2020, 14h40
MarcelG

Bonjour à vous, Bonjour au Forum,

Voir cette contribution.

Bonjour, merci pour vos réponses,

J'ai utilisé le code de halaster08 que j'ai modifié pour convenir à mes besoins et ça fonctionne, cependant ce code fait des itérations des cases à 2 a 1001 et j'aimerais pouvoir mettre une condition permettant d'ajuster automatiquement ce nombre d'itérations au nombre de lignes du tableau, comment-faire ?

Je passerai ensuite le sujet en résolu.

Merci beaucoup

Pour info pour ceux qui tomberaient sur ce sujet plus tard voici le code modifié, permettant d'écrire le corps du mail dans une zone de texte placée dans la feuille Excel.
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 Sub test() Dim ObjOutlook As Object, txt As String, cel As Range Set ObjOutlook = CreateObject("outlook.application") For i = 2 To 1001 Set oBjMail = ObjOutlook.CreateItem(olMailItem) With oBjMail .Display .To = Cells(i, 3).Value .CC = "" 'copie .Subject = "Sujet du mail" 'titre .Body = ActiveSheet.TextBoxes(1).Text 'message 'pièces jointes .Attachments.Add Cells(i, 4).Value 'au choix l'une des trois lignes suivantes .Display 'pour afficher le message dans outlook '.Save 'pour le sauver dans les brouillons '.send 'pour l'envoyer End With Next i End Sub

21/10/2020, 15h04
joe.levrai

Bonjour,

tu travailles dangereusement en ne rattachant pas Cells() à la feuille parente. De ce fait, si la feuille n'est pas la feuille active, gare aux dégâts :aie:

Code:

For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
21/10/2020, 15h10
Canian

Merci de ta réponse Joe !

Je pense avoir compris ton message, tu veux dire que lorsque je lance la macro, ça peut la lancer sur une autre feuille et vu que Cells n'est pas rattachée à la feuille parente, ça créerait un grand nombre d'itérations qui ferait tout buguer ?

Si c'est le cas je ne sais absolument pas comment faire mais je vais chercher ça sur internet, merci de l'info :D
21/10/2020, 15h26
halaster08

Citation:

Envoyé par joe.levrai

tu travailles dangereusement en ne rattachant pas Cells() à la feuille parente. De ce fait, si la feuille n'est pas la feuille active, gare aux dégâts :aie:

Tu as bien raison, c'est une mauvaise habitude de ma part, souvent j'attache ce genre de macro a un bouton, qui se trouve sur la bonne feuille, pour des utilisateurs qui ne savent utiliser les macros autrement donc je ne me fait pas de soucis sur le lancement depuis une mauvaise feuille

Citation:

Envoyé par Canian

Je pense avoir compris ton message, tu veux dire que lorsque je lance la macro, ça peut la lancer sur une autre feuille et vu que Cells n'est pas rattachée à la feuille parente, ça créerait un grand nombre d'itérations qui ferait tout buguer ?

Sans faire un grand nombre d'itération, rien qu'a la première, si tu n'es pas sur la bonne feuille tu vas forcément avoir des données qui ne correspondent pas
Il est donc généralement plus prudent de précéder chaque cellule par sa feuille parente (et éventuellement le classeur aussi si besoin) et donc remplacer cells() par worksheet().cells()

Etant donné que tu travailles déjà avec un bloc With/End With sur le mailitem, tu places la feuille dans une variable Worksheet et tu préfixes tes Ranges/Cells par cette variable

Par ailleurs, tu mélanges le Late/Early Binding, en utilisant une variable Objet pour désigner Outlook (Late), mais tu utilises la constante olMailItem qui est propre à la bibliothèque Outlook (Early)

J'ai remplacé la constante par son équivalent numérique.

Ainsi, en late binding, il n'y a plus à se soucier des versions du pack offices si c'est une procédure susceptible d'être utilisées dans des écosystèmes différents du tiens
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Sub test() Dim ObjOutlook As Object, MaFeuille As Worksheet Set ObjOutlook = CreateObject("outlook.application") Set MaFeuille = ThisWorkbook.Worksheets("MaFeuille") For i = 2 To MaFeuille.Cells(MaFeuille.Rows.Count, 1).End(xlUp).Row With ObjOutlook.CreateItem(0) 'olMailItem .To = MaFeuille.Cells(i, 3).Value .Subject = "Sujet du mail" .Body = MaFeuille.TextBoxes(1).Text .Attachments.Add MaFeuille.Cells(i, 4).Value .Display End With Next i Set ObjOutlook = Nothing End Sub

Bonjour à vous,

Déjà en premier lieu merci pour vos réponses elles m'ont été d'une grande aide.

Bon je me suis mis à apprendre a coder en VBA depuis mon dernier message parce que je ne comprenais pas grand chose (ce n'est pas du tout mon domaine, je suis étudiant en ressources humaines) et j'ai réussi à développer cette macro d'envoi automatique de mail avec pièce jointe différente à partir d'un tableau.

Elle est surement très mal rédigée et surement bien trop complexe pour ce qu'elle fait mais je n'ai pas encore les connaissances suffisantes pour pouvoir l'assouplir.

Cependant, j'ai un soucis qui persiste, il arrive que pour une ou plusieurs personnes, on ne possède pas la pièce jointe correspondante ce qui engendre une erreur lors de la création du mail, durant l'étape d'ajout de la pièce jointe. Cela fait stopper la macro et donc ne traite pas les lignes suivantes du tableau. Comment faire pour sauter cette ligne si le code ne trouve pas la pièce jointe correspondante dans le dossier ?

Merci d'avance pour vos réponses :D

Voici le code :

(A noter que sur la ligne : .Attachments.Add "Chemin d'accès\Publipostage\Test\Attestation Pôle Emploi - " & Resultat & " 2020 - " & Worksheet(Feuille).Cells(i, 2) & " " & Worksheet(Feuille).Cells(i, 3) & ".pdf" J'ai volontairement mis "Chemin d'accès" pour des raisons de confidentialité dû à mon travail.)

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
Sub EnvoiMail()
 
    Dim ObjOutlook As Object, Worksheet As Object, txt As String, cel As Range
    Set ObjOutlook = CreateObject("outlook.application")
    Set Worksheet = Sheets()
 
    Dim Resultat As String, Feuille As Long, Envoi As Boolean
    Feuille = 0
    Résultat = "Rien"
    Envoi = False
 
Do While Envoi = False
    Do While Feuille = 0
            Resultat = InputBox("Pour quel mois voulez-vous envoyer les attestations pôle emploi ?", "Sélection du mois")
 
 
        If Resultat = "Janvier" Then
            Feuille = 1
        ElseIf Resultat = "Février" Then
            Feuille = 2
        ElseIf Resultat = "Mars" Then
            Feuille = 3
        ElseIf Resultat = "Avril" Then
            Feuille = 4
        ElseIf Resultat = "Mai" Then
            Feuille = 5
        ElseIf Resultat = "Juin" Then
            Feuille = 6
        ElseIf Resultat = "Juillet" Then
            Feuille = 7
        ElseIf Resultat = "Août" Then
            Feuille = 8
        ElseIf Resultat = "Septembre" Then
            Feuille = 9
        ElseIf Resultat = "Octobre" Then
            Feuille = 10
        ElseIf Resultat = "Novembre" Then
            Feuille = 11
        ElseIf Resultat = "Décembre" Then
            Feuille = 12
        Else: MsgBox "Le mois sélectionné n'est pas bon, veuillez réessayer." & Chr(10) & Chr(10) & "Attention : Il faut inscrire l'orthographe exact, en commençant par une majuscule et en plaçant les accents.", vbOKOnly, "Erreur"
            GoTo LastLine
        End If
    Loop
    MsgBox "Le mois sélectionné est " & Resultat & ".", vbOKOnly, Confirmation
 
    If Worksheet(Feuille).Cells(1, 2) = "" Then
                MsgBox "Attention la 1ère ligne est vide, elle doit comporter les en-têtes du tableau." & Chr(10) & Chr(10) & "Veuillez rectifier le tableau ou vérifier que vous avez sélectionné le bon mois." & Chr(10) & Chr(10) & "Information : Le mois sélectionné actuellement est " & Resultat, vbOKOnly, "Erreur"
            ElseIf Worksheet(Feuille).Cells(2, 1) = "" Then
                MsgBox "Attention la 1ère colonne est vide" & Chr(10) & Chr(10) & "Veuillez rectifier le tableau ou vérifier que vous avez sélectionné le bon mois." & Chr(10) & Chr(10) & "Information : Le mois sélectionné actuellement est " & Resultat, vbOKOnly, "Erreur"
        Else 'Bloc permettant de vérifier qu'il y a un tableau et qu'il est bien positionné
            Envoi = True
        End If
   Loop
 
 
   If MsgBox("L'envoi des mails pour le mois de " & Resultat & " va commencer." & Chr(10) & Chr(10) & "Confirmez-vous ?", vbOKCancel, "Confirmation") = vbCancel Then
                    GoTo LastLine
                Else
        Worksheet(Feuille).Cells(1, 11) = "Pièce jointe"
    End If
 
    For i = 2 To Worksheet(Feuille).Cells(Rows.Count, 1).End(xlUp).Row
 
        If i = 10 Or i = 20 Or i = 30 Or i = 40 Or i = 0 Or i = 60 Or i = 70 Or i = 80 Then
        MsgBox "Appuyez sur Ok pour préparer les 10 prochaines mails", vbOKOnly, "Confirmation" 'Boite de dialogue permettant de faire des paliers de création de 10 mails max
            End If
 
                         Worksheet(Feuille).Cells(i, 2) = UCase(Worksheet(Feuille).Cells(i, 2))
            If Worksheet(Feuille).Cells(i, 2).Interior.ColorIndex <> 2 Then
                With Worksheet(Feuille).Cells(i, 11)
                    .Hyperlinks.Add Anchor:=Worksheet(Feuille).Cells(i, 11), Address:="Publipostage\Test\Attestation Pôle Emploi - " & Resultat & " 2020 - " & Worksheet(Feuille).Cells(i, 2) & " " & Worksheet(Feuille).Cells(i, 3) & ".pdf"
                End With 'Création d'une colonne supplémentaire contenant le lien hypertexte correspondant
 
            Set oBjMail = ObjOutlook.CreateItem(olMailItem)
                With oBjMail
                    .Display
                    .To = Worksheet(Feuille).Cells(i, 8).Value
                    .CC = "" 'copie
                    .Subject = "Votre attestation Pôle Emploi - " & Resultat 'titre
                    .Body = Worksheet(13).TextBoxes(1).Text 'message
                    'pièces jointes
                    .Attachments.Add "Chemin d'accès\Publipostage\Test\Attestation Pôle Emploi - " & Resultat & " 2020 - " & Worksheet(Feuille).Cells(i, 2) & " " & Worksheet(Feuille).Cells(i, 3) & ".pdf"
 
                    'au choix l'une des trois lignes suivantes
                    .Display 'pour afficher le message dans outlook
                    '.Save 'pour le sauver dans les brouillons
                    '.send 'pour l'envoyer
 
                End With
            Else
            End If
    Next i
 
MsgBox "Tous les mails ont été envoyés.", vbOKOnly, "Terminé"
 
LastLine: End Sub

Bonjour,

LA fonction dir peut te permettre de tester si le fichier existe:

Code:

1
2
3
If Not Dir("Chemin d'accès\Publipostage\Test\Attestation Pôle Emploi - " & Resultat & " 2020 - " & Worksheet(Feuille).Cells(i, 2) & " " & Worksheet(Feuille).Cells(i, 3) & ".pdf") = "" Then
.Attachments.Add "Chemin d'accès\Publipostage\Test\Attestation Pôle Emploi - " & Resultat & " 2020 - " & Worksheet(Feuille).Cells(i, 2) & " " & Worksheet(Feuille).Cells(i, 3) & ".pdf"
End If

23/10/2020, 14h25
Canian

Merci beaucoup ça m'a bien aidé et j'ai terminé ma macro, elle réalise exactement ce que je veux, je clos le sujet :)

Bonjour à tous,

Je pensais en avoir terminé avec cette maudite macro mais me revoilà avec un petit soucis sur lequel je bloque...

Dans un soucis de stabilité de la macro j'aimerais rendre possible le déplacement du dossier contenant le fichier excel et les fichiers à mettre en pièce jointe dans le mail.

Pour cela j'ai tenté d'insérer une variable String que j'ai appelé Path. Ensuite je fige le chemin d'accès au document pour pouvoir le réutiliser dans la pièce jointe puisque si je note "ActiveWorkbook.Path etc", vu que c'est l'application Outlook qui est ouverte, elle devient le nouveau "Active.Workbook".

Cependant cette solution ne fonctionne pas..

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
    For i = 2 To Worksheet(Feuille).Cells(Rows.Count, 1).End(xlUp).Row
 
        If i = 10 Or i = 20 Or i = 30 Or i = 40 Or i = 0 Or i = 60 Or i = 70 Or i = 80 Then
        MsgBox "Appuyez sur Ok pour préparer les 10 prochains mails", vbInformation + vbOKOnly, "Confirmation"  'Boite de dialogue permettant de faire des paliers de création de 10 mails max
            End If
 
                         Worksheet(Feuille).Cells(i, 2) = UCase(Worksheet(Feuille).Cells(i, 2))
            If Worksheet(Feuille).Cells(i, 2).Interior.ColorIndex <> 2 Then
                With Worksheet(Feuille).Cells(i, 16)
                    .Hyperlinks.Add Anchor:=Worksheet(Feuille).Cells(i, 16), Address:=ActiveWorkbook.Path & "\Attestations par mois par agent\" & Mois & "\Attestation Pôle Emploi - " & Resultat & " 2020 - " & Worksheet(Feuille).Cells(i, 2) & " " & Worksheet(Feuille).Cells(i, 3) & ".pdf"
                End With 'Création d'une colonne supplémentaire contenant le lien hypertexte correspondant
 
                Path = ActiveWorkbook.Path & "\Attestations par mois par agent\" & Mois & "\Attestation Pôle Emploi - " & Resultat & " 2020 - " & Worksheet(Feuille).Cells(i, 2) & " " & Worksheet(Feuille).Cells(i, 3) & ".pdf"
 
            Set oBjMail = ObjOutlook.CreateItem(olMailItem)
                With oBjMail
                    .Display
                    .To = Worksheet(Feuille).Cells(i, 13).Value
                    .CC = "" 'copie
                    .Subject = "Votre attestation Pôle Emploi - " & Resultat 'titre
                    .Body = Worksheet(13).TextBoxes(1).Text 'message
                    'pièces jointes
                        If Not Dir(Path) = "" Then
                                .Attachments.Add = Path
                                .Display
                                Worksheet(Feuille).Cells(i, 16).Interior.Color = RGB(0, 255, 0)
                            Else
                          .Delete
                          Worksheet(Feuille).Cells(i, 16) = "Pièce jointe non disponible dans le dossier, mail non envoyé"
                          Worksheet(Feuille).Cells(i, 16).Interior.Color = RGB(255, 0, 0)
                        End If
 
                    'au choix l'une des quatres lignes suivantes :
                    '.Display 'pour afficher le message dans outlook
                    '.Save 'pour le sauver dans les brouillons
                    '.send 'pour l'envoyer
                    '.delete pour le supprimer
 
                End With
            Else
            End If
    Next i

04/11/2020, 10h41
halaster08

Citation:

Envoyé par Canian

Path = ActiveWorkbook.Path

C'est rarement une bonne idée de nommer une variable avec un nom déjà utilisé par VBA

Citation:

Cependant cette solution ne fonctionne pas..

:cristal:
Un message d'erreur ? si oui lequel et a quelle ligne, sinon que se passe-t-il ?
04/11/2020, 11h03
Canian

En effet mon dernier message manque d'éléments pour comprendre..$

Lorsque je lance la macro tout va bien, je renseigne les informations demandées, puis d'un coup message d'erreur "Erreur d'exécution, échec de l'opération" et lorsque je clique sur débogage, la ligne suivante est surlignée en jaune.

Code:

.Attachments.Add = Path

Je pense donc que c'est dû au fait que lorsque l'objet outlook se créer et s'ouvre, c'est ce dernier qui devient le "ActiveWorkbook" et donc le chemin d'accès à la pièce jointe est modifié, puisque avant cela c'est la feuille excel qui est considérée comme ActiveWorkbook. Je pense donc qu'il y a une erreur :
1 - Le chemin est erroné a cause de la commande ActiveWorkbook : dans ce cas là soit je dois figer le chemin avant l'ouverture de l'objet Outlook (c'est ce que j'ai tenté avec la variable String Path) mais ça ne fonctionne pas, donc la méthode est mauvaise.

Avant cela j'utilisais un chemin d'accès bien précis qui se modifie seulement en fonction de la ligne dans le tableau Excel, mais ce n'est pas viable puisque si je bouge le dossier, d'un ordi a un autre ou d'un dossier à un autre, je vais avoir des erreurs.
04/11/2020, 11h44
halaster08

Citation:

Envoyé par Canian

Je pense donc que c'est dû au fait que lorsque l'objet outlook se créer et s'ouvre, c'est ce dernier qui devient le "ActiveWorkbook"

Non, Workbook c'est un classeur excel, c'est très différent d'un objet Outlook
Note que tu pourrais essayé Thisworkbook qui fait référence au classeur contenant la macro, peut importe celui qui est actif, mais ça ne devrait rien changer au problème.

Citation:

Code:

.Attachments.Add = Path

Pas de =

Code:

.Attachments.Add Path

Cependant j'insiste encore sur le fait qu'utiliser path comme nom de variable n'est pas une pratique
04/11/2020, 12h29
Canian

C'est bon c'était bien ça le problème, c'est le "=" qui ne passait pas..

Merci de ton aide, j'ai bien modifié "Path" je l'ai renommé pour que ça n'interfère pas, on sait jamais tu as raison !

Encore un grand merci :D

Comment inclure la signature dans ce type de mail automatique

J'ai adapté le script trouvé :

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
Sub EnvMailAuto()
 
Dim ObjOutlook As Object, MaFeuille As Worksheet
 
Set ObjOutlook = CreateObject("outlook.application")
 
Dim i
Set MaFeuille = ThisWorkbook.Worksheets("FabMessage")
    For i = 2 To MaFeuille.Cells(MaFeuille.Rows.Count, 1).End(xlUp).Row
        With ObjOutlook.CreateItem(0)  'olMailItem
 
            .To = MaFeuille.Cells(i, 3).Value
 
            .CC = "mon mail@gmail.com" 'copie
 
            .Subject = MaFeuille.Cells(i, 1).Text   'titre
 
            .body = MaFeuille.Cells(i, 2).Text  'message
 
            'pièces jointes
            .Attachments.Add MaFeuille.Cells(i, 4).Value
 
            'au choix l'une des trois lignes suivantes
            .Display 'pour afficher le message dans outlook
            '.Save 'pour le sauver dans les brouillons
            '.send 'pour l'envoyer
 
        End With
    Next i
Set ObjOutlook = Nothing
 
End Sub

Je ne sais pas comment inclure ma signature dans les mails générés, merci de m'aider si savez faire !

Salut,

Pour insérer une signature, j'utilise ce code du "grand spécialiste" Oliv,
(Voir le lien en libellé)

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
Sub InsertSignature(objMail As Outlook.MailItem, Optional SignatureName As String)
 
''https://www.developpez.net/forums/blogs/191381-oliv/b4076/inserer-signature-lemail-actif-outlook-2016/
 
'---------------------------------------------------------------------------------------
' Procedure : InsertSignature
' Author    : OLiv
' Version   : 2.2
' Date      : 18/06/2020
' Purpose   : Ajout d'une signature pour OUTLOOK 2010,2013,2016,365
'---------------------------------------------------------------------------------------
'
Dim wd As Object, obSelection As Object
Dim oBookmarks As Object, oBookmark As Object    'Word.Bookmark
Dim enviro As String, strSigFilePath As String
Const wdStory = 6
Const wdParagraph = 4
Const wdGoToBookmark = -1
Const wdExtend = 1
Const wdSortByName = 0
Const wdMove = 0
 
enviro = CStr(Environ("appdata"))
strSigFilePath = enviro & "\Microsoft\Signatures\"
 
Set wd = objMail.GetInspector.WordEditor
 
If SignatureName = "" Then
      Dim objSig As Object
      Set objSig = wd.Application.EmailOptions.EmailSignature
      SignatureName = objSig.NewMessageSignature
End If
 
Set obSelection = wd.Application.Selection
 
Set oBookmarks = wd.Bookmarks
 
On Error Resume Next
Set oBookmark = oBookmarks("_MailAutoSig")
On Error GoTo 0
 
If oBookmark Is Nothing Then
 
      'si pas de bookmark signture je vais à la fin.
      Set obSelection = wd.Application.Selection
      obSelection.EndOf Unit:=wdStory, Extend:=wdMove
      '      obSelection.Move wdStory, -1
      obSelection.Move wdParagraph, 1
      obSelection.Paragraphs.Add
      obSelection.Move wdParagraph, 1
      Set oBookmark = obSelection.Bookmarks.Add("_MailAutoSig", obSelection.Range)
      oBookmark.Range.Text = "_Signature"
      oBookmark.End = wd.Range.End
 
End If
 
If dir(strSigFilePath & SignatureName & ".htm", vbNormal) <> "" Then
 
      'oBookmark.Select
      Dim orng As Object    'Word.Range
      Set orng = wd.Range
      orng.Start = orng.Bookmarks("_MailAutoSig").Range.Start
      orng.End = orng.Bookmarks("_MailAutoSig").Range.End
      orng.InsertFile Filename:=strSigFilePath & SignatureName & ".htm", Range:="", ConfirmConversions:= _
      False, Link:=False, Attachment:=False
      orng.End = wd.Range.End
      With wd.Bookmarks
            .Add Range:=orng, Name:="_MailAutoSig"
            .DefaultSorting = wdSortByName
            .ShowHidden = False
      End With
 
      'On Error Resume Next
      'Set oBookmark = wd.Bookmarks("_MailAutoSig")
      ' oBookmark.End = wd.Range.End
      'oBookmark.Select
 
      obSelection.Move wdStory, -1
 
 
End If
 
Set orng = Nothing
 
Set oBookmark = Nothing
Set obSelection = Nothing
 
End Sub

Pour l'appel

Code:

1
2
3
4
5
6
7
8
9
10
11
With MonItem
 
               '.......
               'Toutes les propriétés .To, .Cc....
 
               Call InsertSignature(objMail:=MonItem, SignatureName:="TOTO")
 
Envoi:
              .Send
 
End With

Ici, "TOTO" représente le nom de la signature tel qu'il paraît dans le menu Outlook / Signatures

"MonItem" est l'item Outlook déclaré

Code:

1
2
3
4
5
6
7
Requiert une référence à la bibliothèque d'objets Outlook
Dim Applic_Outlook As Outlook.Application
'Crée l'objet Outlook
Set Applic_Outlook = New Outlook.Application
 
Dim MonItem As Outlook.MailItem
Set MonItem = Applic_Outlook.CreateItem(olMailItem)