automatisation de l'insertion du signature en fonction d'un objet

**antony34200** · 10/06/2020, 21h50

Ça ne fonctionne plus, je n'ai pas la bonne signature, c'est celle par défaut qui s’insère.
et pour l'insertion de PJ ... je ne sais pas par quoi remplacer le code ...

**antony34200** · 10/06/2020, 22h02

Du coup, j'ai remis le code de mon post 14.
la signature s’insère bien.
Je vais faire de la maniere suivante :
ma signature va s'apeller bulletin et mon objet s'appellera bulletin salaire sois de. et si j'ai un retour, je repondrais en faisant un nouveau mail, ou je n'écrirais pas pas bulletin, mais salaire uniquement ...
Par contre, pour l'insertion des PJ, j'ai besoin d'un coup de main... je ni comprend rien en VBA

**Oliv-** · 11/06/2020, 14h45

Peux tu être plus précis quand tu dis que cela ne fonctionne plus ?

en repartant du code #14

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
128
129
130
131
132
133
134
135
136
137
138
 
 
 
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'---------------------------------------------------------------------------------------
' Procedure : Application_ItemSend
' Author    : OCTU
'---------------------------------------------------------------------------------------
'
    If Not Item.Class = olMail Then GoTo Fin
' pour ne traiter que les nouveaux messages
 
    If Item.ReceivedByName <> "" Or Item.Sent = True Or Item.ConversationTopic <> "" Then GoTo Fin
 
'on teste le sujet
    If InStr(1, Item.Subject, "contrat semaine", vbTextCompare) Then
        '   voir ici
        '   <a href="https://www.developpez.net/forums/blogs/191381-oliv/b4076/inserer-signature-lemail-actif-outlook-2016" target="_blank">https://www.developpez.net/forums/bl...f-outlook-2016</a>
        Call InsertSignature(Item, "contrat")
        Item.Save
    ElseIf InStr(1, Item.Subject, "salaire mois de", vbTextCompare) Then
 
        Call InsertSignature(Item, "salaire")
        Item.Save
 
    End If
 
    'on ajoute des PJ selon l'adresse Email du premier destinataire
 
    EmailDest = Split(GetSMTPAddressForRecipient(Item.Recipients(1)), "@")(0)
    Dim MonDossierPJ
    MonDossierPJ = "C:\Users\PC - Bureau\Desktop\a envoyer\"
 
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set AFolder = Fso.GetFolder(MonDossierPJ)
 
 
    For Each Afile In AFolder.Files
 
        If InStr(1, Afile, EmailDest, vbTextCompare) > 0 Then
            Item.Attachments.Add (Afile.Path)
        End If
    Next Afile
 
Fin:
End Sub
 
'   voir ici
'   <a href="https://www.developpez.net/forums/blogs/191381-oliv/b4076/inserer-signature-lemail-actif-outlook-2016" target="_blank">https://www.developpez.net/forums/bl...f-outlook-2016</a>
 
Function GetSMTPAddressForRecipient(recip As Outlook.Recipient) As String
'---------------------------------------------------------------------------------------
' Procedure : GetSMTPAddressForRecipient
' Author    : Oliv-
' Date      : 21/01/2015
' Purpose   : Obtenir l'adresse SMTP =xxx@xxx.xxx
'---------------------------------------------------------------------------------------
'Dim recip As Outlook.Recipient
'pas de adresse SMTP si Contact d'origine EXCHANGE mais copié dans Pop
    GetSMTPAddressForRecipient = ""
    On Error GoTo Fin
    Dim PA As Outlook.PropertyAccessor
    Const PR_SMTP_ADDRESS As String = _
          "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Set PA = recip.PropertyAccessor
    'Debug.Print recip.Name & " SMTP=" _
     & pa.GetProperty(PR_SMTP_ADDRESS)
    GetSMTPAddressForRecipient = PA.GetProperty(PR_SMTP_ADDRESS)
Fin:
    If GetSMTPAddressForRecipient = "" Then GetSMTPAddressForRecipient = recip
End Function
 
 
Sub InsertSignature(objMail As MailItem, SignatureName As String)
'---------------------------------------------------------------------------------------
' Procedure : InsertSignature
' Author    : OLiv
' Version   : 2
' Date      : 09/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, strSigFilePath
    Const wdStory = 6
    Const wdParagraph = 4
    Const wdGoToBookmark = -1
    Const wdExtend = 1
    Const wdSortByName = 0
    enviro = CStr(Environ("appdata"))
    strSigFilePath = enviro & "\Microsoft\Signatures\"
 
 
    Set wd = objMail.GetInspector.WordEditor
 
    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
        Set obSelection = wd.Application.Selection
        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
End Sub

POur la partie PJ

ta règle

Et les pièces à joindre : DUPONT Jdocument.pdf (la première lettre du prénom est noté dans le nom du document uniquement si j'ai d'autre document avec le même nom)
Ex :
DUPONT Jdocument.pdf (pour DUPONT Jean)
DUPONT Cdocument.pdf (pour DUPONT Charles)

est difficilement adaptable pour un programme automatique !

ne peux tu pas nommer tes documents jean.dupontdocument1.pdf

de plus dans ton cas il est peut être préférable de créer une macro qui se déclencherait par un clic sur un bouton qu'une macro à l'envoi

**antony34200** · 11/06/2020, 20h21

Bonsoir,
j'ai tellement modifié le code que je ne sais plus ou j'en suis ...
a un moment, l'insertion de la signature fonctionnait, maintenant ça ne fonctionne plus ...
Concernant la façon de nommé les doucuments, mon soucis est que j'ai besoin qu'ils soient triés par nom de famille et par ordre alphabétique ...
Si je nomme mes documents de cette façon : DUPONT;Chalesdocument.pdf, est-ce que ça fonctionnerais ?

**antony34200** · 11/06/2020, 20h32

avec ce code

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
128
129
130
131
132
133
134
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'---------------------------------------------------------------------------------------
' Procedure : Application_ItemSend
' Author    : OCTU
'---------------------------------------------------------------------------------------
'
    If Not Item.Class = olMail Then GoTo Fin
'    pour ne traiter que les nouveaux messages
 
    If Item.ReceivedByName <> "" Or Item.Sent = True Or Item.ConversationTopic <> "" Then GoTo Fin
'on teste le sujet
    If InStr(1, Item.Subject, "contrat semaine", vbTextCompare) Then
        '   voir ici
        '   <a href="https://www.developpez.net/forums/blogs/191381-oliv/b4076/inserer-signature-lemail-actif-outlook-2016" target="_blank">https://www.developpez.net/forums/bl...f-outlook-2016</a>
        Call InsertSignature(Item, "contrat")
        Item.Save
    ElseIf InStr(1, Item.Subject, "salaire mois de", vbTextCompare) Then
 
        Call InsertSignature(Item, "salaire")
        Item.Save
 
    End If
 
    'on ajoute des PJ selon l'adresse Email du premier destinataire
 
    EmailDest = Split(GetSMTPAddressForRecipient(Item.Recipients(1)), "@")(0)
    Dim MonDossierPJ
    MonDossierPJ = "C:\Users\PC - Bureau\Desktop\a envoyer\"
 
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set AFolder = fso.GetFolder(MonDossierPJ)
 
 
    For Each Afile In AFolder.Files
 
        If InStr(1, Afile, EmailDest, vbTextCompare) > 0 Then
            Item.Attachments.Add (Afile.Path)
        End If
    Next Afile
 
Fin:
End Sub
 
'   voir ici
'   <a href="https://www.developpez.net/forums/blogs/191381-oliv/b4076/inserer-signature-lemail-actif-outlook-2016" target="_blank">https://www.developpez.net/forums/bl...f-outlook-2016</a>
 
Function GetSMTPAddressForRecipient(recip As Outlook.Recipient) As String
'---------------------------------------------------------------------------------------
' Procedure : GetSMTPAddressForRecipient
' Author    : Oliv-
' Date      : 21/01/2015
' Purpose   : Obtenir l'adresse SMTP =xxx@xxx.xxx
'---------------------------------------------------------------------------------------
'Dim recip As Outlook.Recipient
'pas de adresse SMTP si Contact d'origine EXCHANGE mais copié dans Pop
    GetSMTPAddressForRecipient = ""
    On Error GoTo Fin
    Dim PA As Outlook.PropertyAccessor
    Const PR_SMTP_ADDRESS As String = _
          "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Set PA = recip.PropertyAccessor
    'Debug.Print recip.Name & " SMTP=" _
     & pa.GetProperty(PR_SMTP_ADDRESS)
    GetSMTPAddressForRecipient = PA.GetProperty(PR_SMTP_ADDRESS)
Fin:
    If GetSMTPAddressForRecipient = "" Then GetSMTPAddressForRecipient = recip
End Function
 
 
Sub InsertSignature(objMail As MailItem, SignatureName As String)
'---------------------------------------------------------------------------------------
' Procedure : InsertSignature
' Author    : OLiv
' Version   : 2
' Date      : 09/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, strSigFilePath
    Const wdStory = 6
    Const wdParagraph = 4
    Const wdGoToBookmark = -1
    Const wdExtend = 1
    Const wdSortByName = 0
    enviro = CStr(Environ("appdata"))
    strSigFilePath = enviro & "\Microsoft\Signatures\"
 
 
    Set wd = objMail.GetInspector.WordEditor
 
    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
        Set obSelection = wd.Application.Selection
        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
End Sub

la signature ne s'insert pas.

et avec ce code :

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
128
129
130
131
132
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'---------------------------------------------------------------------------------------
' Procedure : Application_ItemSend
' Author    : OCTU
'---------------------------------------------------------------------------------------
'
    If Not Item.Class = olMail Then GoTo Fin
 
'on teste le sujet
    If InStr(1, Item.Subject, "contrat semaine", vbTextCompare) Then
        '   voir ici
        '   <a href="https://www.developpez.net/forums/blogs/191381-oliv/b4076/inserer-signature-lemail-actif-outlook-2016" target="_blank">https://www.developpez.net/forums/bl...f-outlook-2016</a>
        Call InsertSignature(Item, "contrat")
        Item.Save
    ElseIf InStr(1, Item.Subject, "salaire mois de", vbTextCompare) Then
 
        Call InsertSignature(Item, "salaire")
        Item.Save
 
    End If
 
    'on ajoute des PJ selon l'adresse Email du premier destinataire
 
    EmailDest = Split(GetSMTPAddressForRecipient(Item.Recipients(1)), "@")(0)
    Dim MonDossierPJ
    MonDossierPJ = "C:\Users\PC - Bureau\Desktop\a envoyer\"
 
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set AFolder = fso.GetFolder(MonDossierPJ)
 
 
    For Each Afile In AFolder.Files
 
        If InStr(1, Afile, EmailDest, vbTextCompare) > 0 Then
            Item.Attachments.Add (Afile.Path)
        End If
    Next Afile
 
Fin:
End Sub
 
'   voir ici
'   <a href="https://www.developpez.net/forums/blogs/191381-oliv/b4076/inserer-signature-lemail-actif-outlook-2016" target="_blank">https://www.developpez.net/forums/bl...f-outlook-2016</a>
 
Function GetSMTPAddressForRecipient(recip As Outlook.Recipient) As String
'---------------------------------------------------------------------------------------
' Procedure : GetSMTPAddressForRecipient
' Author    : Oliv-
' Date      : 21/01/2015
' Purpose   : Obtenir l'adresse SMTP =xxx@xxx.xxx
'---------------------------------------------------------------------------------------
'Dim recip As Outlook.Recipient
'pas de adresse SMTP si Contact d'origine EXCHANGE mais copié dans Pop
    GetSMTPAddressForRecipient = ""
    On Error GoTo Fin
    Dim PA As Outlook.PropertyAccessor
    Const PR_SMTP_ADDRESS As String = _
          "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Set PA = recip.PropertyAccessor
    'Debug.Print recip.Name & " SMTP=" _
     & pa.GetProperty(PR_SMTP_ADDRESS)
    GetSMTPAddressForRecipient = PA.GetProperty(PR_SMTP_ADDRESS)
Fin:
    If GetSMTPAddressForRecipient = "" Then GetSMTPAddressForRecipient = recip
End Function
 
 
Sub InsertSignature(objMail As MailItem, SignatureName As String)
'---------------------------------------------------------------------------------------
' Procedure : InsertSignature
' Author    : OLiv
' Version   : 2
' Date      : 09/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, strSigFilePath
    Const wdStory = 6
    Const wdParagraph = 4
    Const wdGoToBookmark = -1
    Const wdExtend = 1
    Const wdSortByName = 0
    enviro = CStr(Environ("appdata"))
    strSigFilePath = enviro & "\Microsoft\Signatures\"
 
 
    Set wd = objMail.GetInspector.WordEditor
 
    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
        Set obSelection = wd.Application.Selection
        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
End Sub

La signature s'insert.

**Oliv-** · 12/06/2020, 11h12

Envoyé par antony34200

Bonsoir,
j'ai tellement modifié le code que je ne sais plus ou j'en suis ...
a un moment, l'insertion de la signature fonctionnait, maintenant ça ne fonctionne plus ...
Concernant la façon de nommé les doucuments, mon soucis est que j'ai besoin qu'ils soient triés par nom de famille et par ordre alphabétique ...
Si je nomme mes documents de cette façon : DUPONT;Chalesdocument.pdf, est-ce que ça fonctionnerais ?

L'important pour le programme c'est que ce soit toujours le même schéma de nommage des documents et qu'il sache où trouver l'info !
c'est pour cela que c'est plus simple de prendre la partie à gauche de l'@

Imaginons Charles DUPONT il peut avoir une adresse Email :

charles.dupont@toto.fr ou dupont.charles@toto.fr ou encore cdupont@toto.fr

et s'il se nomme jean charles dupont ?

ensuite est-ce que son nom est normé ? ce sont des adresses internes ?

est-ce qu'un contact est associé dans outlook ?

le prénom est il qualifé ?

c'est vite très compliqué d'automatiser !

**antony34200** · 12/06/2020, 14h05

Bonjour,
Pour faire simple.
je suis RH et je passe mes journées à envoyer des mails (environ 100 par jour) à du personnel.
Tout mon personnel n'a pas créer leur mail de la façon que vous dites, car se ne sont pas des mails interne. La plupart du temps c'est du style : skate34@XXX.com, ils n'ont pas tous eu l'idée de créer leur adresse mail avec leur nom et prénom. C'est pour ça que je me sert de l’onglet "PERSONNE" pour enregistrer mes contacts de cette façon :
Nom : Capture.PNG
Affichages : 86
Taille : 52,7 Ko

Nom : Capture.PNG
Affichages : 86
Taille : 52,7 Ko

Et sincèrement, une fois que je les ais enregistré, je ne sais plus comment est construit leur adresse mail ...
Quand je veut le leur envoyer un mail, je clic sur "A", je tape les 3 ou 4 première lettre de leur nom de famille et je sélectionne la personne que je veux.
Idem pour quand je leur envoi leur bulletin de salaire. j'ai plus de 500 mails à faire sur 1 ou 2 jours en fin de mois.
D’où une insertion automatique de la signature selon l'objet, ça c'est réglé (dans mes signature j'ai fait un texte commun), et si c'est possible l'insertion automatique des PJ selon "afficher comme"

**Oliv-** · 15/06/2020, 11h49

SAlut
Peux tu tester ce code
du coup j'ai changé il faudra exécuter manuellement(tu pourras ajouter un bouton dans le ruban) le code après avoir saisi le destinataire et le sujet du mail.

pour les pj toutes PJ contenant NOM P

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
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
 
 
Private Sub maj_signature_et_PJ()
'---------------------------------------------------------------------------------------
' Procedure : Application_ItemSend
' Author    : OCTU
'---------------------------------------------------------------------------------------
'
    Dim item As Object
    Dim CC As ContactItem
 
    On Error Resume Next
    Set item = ActiveInspector.CurrentItem
 
    If item Is Nothing Then MsgBox "pas de nouveau Email !", vbCritical: End
    If Not item.Class = olMail Then GoTo Fin
    ' pour ne traiter que les nouveaux messages
 
    If item.ReceivedByName <> "" Or item.Sent = True Or item.ConversationID <> "" Then GoTo Fin
 
    'on teste le sujet pour changer la signature
    If InStr(1, item.Subject, "contrat semaine", vbTextCompare) Then
        '   voir ici
        '   <a href="https://www.developpez.net/forums/blogs/191381-oliv/b4076/inserer-signature-lemail-actif-outlook-2016" target="_blank">https://www.developpez.net/forums/bl...f-outlook-2016</a>
 
        '###################################################################
        'A ADAPTER
        '###################################################################
        Call InsertSignature(item, "perso")
        '###################################################################
 
        item.Save
    ElseIf InStr(1, item.Subject, "salaire mois de", vbTextCompare) Then
 
        '###################################################################
        'A ADAPTER
        '###################################################################
        Call InsertSignature(item, "responsive")
        '###################################################################
 
        item.Save
 
    End If
 
    'on ajoute des PJ selon l'adresse Email du premier destinataire
 
    Set CC = item.Recipients(1).AddressEntry.GetContact
 
    If CC Is Nothing Then MsgBox "pas de contact", vbCritical, "Erreur": End
    EmailDest = CC.LastName & " " & Left(CC.FirstName, 1)
 
    MsgBox "Prénom =" & CC.FirstName & vbCr & "Nom =" & CC.LastName & vbCr & CC.Email1Address & vbCr & vbCr & "-->[" & EmailDest & "]", vbOKOnly, "Recherche des PJ pour"
    'EmailDest = Split(GetSMTPAddressForRecipient(item.Recipients(1)), "@")(0)
 
    Dim MonDossierPJ
 
    '###################################################################
    'A ADAPTER
    '###################################################################
    ' MonDossierPJ = "C:\Users\PC - Bureau\Desktop\a envoyer\"
    MonDossierPJ = "C:\temp\a envoyer\"
    '##################################################################
 
    On Error GoTo 0
    If Len(EmailDest) > 3 Then
        Set Fso = CreateObject("Scripting.FileSystemObject")
        Set AFolder = Fso.GetFolder(MonDossierPJ)
 
 
        For Each Afile In AFolder.Files
 
            If InStr(1, Afile, EmailDest, vbTextCompare) > 0 Then
                item.Attachments.add (Afile.path)
            End If
        Next Afile
    Else
        MsgBox "Prénom =" & CC.FirstName & vbCr & "Nom =" & CC.LastName & vbCr & CC.Email1Address & vbCr & vbCr & "-->[" & EmailDest & "]", vbCritical, "Pas de nom/prénom !"
    End If
Fin:
End Sub
 
'   voir ici
'   <a href="https://www.developpez.net/forums/blogs/191381-oliv/b4076/inserer-signature-lemail-actif-outlook-2016" target="_blank">https://www.developpez.net/forums/bl...f-outlook-2016</a>
 
Function GetSMTPAddressForRecipient(recip As Outlook.Recipient) As String
'---------------------------------------------------------------------------------------
' Procedure : GetSMTPAddressForRecipient
' Author    : Oliv-
' Date      : 21/01/2015
' Purpose   : Obtenir l'adresse SMTP =xxx@xxx.xxx
'---------------------------------------------------------------------------------------
'Dim recip As Outlook.Recipient
'pas de adresse SMTP si Contact d'origine EXCHANGE mais copié dans Pop
    GetSMTPAddressForRecipient = ""
    On Error GoTo Fin
    Dim PA As Outlook.propertyAccessor
    Const PR_SMTP_ADDRESS As String = _
          "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Set PA = recip.propertyAccessor
    'Debug.Print recip.Name & " SMTP=" _
     & pa.GetProperty(PR_SMTP_ADDRESS)
    GetSMTPAddressForRecipient = PA.GetProperty(PR_SMTP_ADDRESS)
Fin:
    If GetSMTPAddressForRecipient = "" Then GetSMTPAddressForRecipient = recip
End Function
 
 
Sub InsertSignature(objMail As MailItem, SignatureName As String)
'---------------------------------------------------------------------------------------
' Procedure : InsertSignature
' Author    : OLiv
' Version   : 2
' Date      : 09/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, strSigFilePath
    Const wdStory = 6
    Const wdParagraph = 4
    Const wdGoToBookmark = -1
    Const wdExtend = 1
    Const wdSortByName = 0
    enviro = CStr(Environ("appdata"))
    strSigFilePath = enviro & "\Microsoft\Signatures\"
 
 
    Set wd = objMail.GetInspector.WordEditor
 
    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
        Set obSelection = wd.Application.Selection
        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
End Sub

**antony34200** · 15/06/2020, 16h58

Bonjour,
avec le code ci dessous, je peux envoyer les mails, mais il y a ni PJ ni signature, juste ma signature par defaut

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
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
 
 
Private Sub maj_signature_et_PJ()
'---------------------------------------------------------------------------------------
' Procedure : Application_ItemSend
' Author    : OCTU
'---------------------------------------------------------------------------------------
'
    Dim item As Object
    Dim CC As ContactItem
 
    On Error Resume Next
    Set item = ActiveInspector.CurrentItem
 
    If item Is Nothing Then MsgBox "pas de nouveau Email !", vbCritical: End
    If Not item.Class = olMail Then GoTo Fin
    ' pour ne traiter que les nouveaux messages
 
    If item.ReceivedByName <> "" Or item.Sent = True Or item.ConversationID <> "" Then GoTo Fin
 
    'on teste le sujet pour changer la signature
    If InStr(1, item.Subject, "contrat semaine", vbTextCompare) Then
        '   voir ici
        '   <a href="https://www.developpez.net/forums/blogs/191381-oliv/b4076/inserer-signature-lemail-actif-outlook-2016" target="_blank">https://www.developpez.net/forums/bl...f-outlook-2016</a>
 
        '###################################################################
        'A ADAPTER
        '###################################################################
        Call InsertSignature(item, "contrat")
        '###################################################################
 
        item.Save
    ElseIf InStr(1, item.Subject, "salaire mois de", vbTextCompare) Then
 
        '###################################################################
        'A ADAPTER
        '###################################################################
        Call InsertSignature(item, "salaire")
        '###################################################################
 
        item.Save
 
    End If
 
    'on ajoute des PJ selon l'adresse Email du premier destinataire
 
    Set CC = item.Recipients(1).AddressEntry.GetContact
 
    If CC Is Nothing Then MsgBox "pas de contact", vbCritical, "Erreur": End
    EmailDest = CC.LastName & " " & Left(CC.FirstName, 1)
 
    MsgBox "Prénom =" & CC.FirstName & vbCr & "Nom =" & CC.LastName & vbCr & CC.Email1Address & vbCr & vbCr & "-->[" & EmailDest & "]", vbOKOnly, "Recherche des PJ pour"
    'EmailDest = Split(GetSMTPAddressForRecipient(item.Recipients(1)), "@")(0)
 
    Dim MonDossierPJ
 
    '###################################################################
    'A ADAPTER
    '###################################################################
    ' MonDossierPJ = "C:\Users\PC - Bureau\Desktop\a envoyer\"
    MonDossierPJ = "C:\Users\PC - Bureau\Desktop\a envoyer\"
    '##################################################################
 
    On Error GoTo 0
    If Len(EmailDest) > 3 Then
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set AFolder = fso.GetFolder(MonDossierPJ)
 
 
        For Each Afile In AFolder.Files
 
            If InStr(1, Afile, EmailDest, vbTextCompare) > 0 Then
                item.Attachments.Add (Afile.Path)
            End If
        Next Afile
    Else
        MsgBox "Prénom =" & CC.FirstName & vbCr & "Nom =" & CC.LastName & vbCr & CC.Email1Address & vbCr & vbCr & "-->[" & EmailDest & "]", vbCritical, "Pas de nom/prénom !"
    End If
Fin:
End Sub
 
'   voir ici
'   <a href="https://www.developpez.net/forums/blogs/191381-oliv/b4076/inserer-signature-lemail-actif-outlook-2016" target="_blank">https://www.developpez.net/forums/bl...f-outlook-2016</a>
 
Function GetSMTPAddressForRecipient(recip As Outlook.Recipient) As String
'---------------------------------------------------------------------------------------
' Procedure : GetSMTPAddressForRecipient
' Author    : Oliv-
' Date      : 21/01/2015
' Purpose   : Obtenir l'adresse SMTP =xxx@xxx.xxx
'---------------------------------------------------------------------------------------
'Dim recip As Outlook.Recipient
'pas de adresse SMTP si Contact d'origine EXCHANGE mais copié dans Pop
    GetSMTPAddressForRecipient = ""
    On Error GoTo Fin
    Dim PA As Outlook.PropertyAccessor
    Const PR_SMTP_ADDRESS As String = _
          "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Set PA = recip.PropertyAccessor
    'Debug.Print recip.Name & " SMTP=" _
     & pa.GetProperty(PR_SMTP_ADDRESS)
    GetSMTPAddressForRecipient = PA.GetProperty(PR_SMTP_ADDRESS)
Fin:
    If GetSMTPAddressForRecipient = "" Then GetSMTPAddressForRecipient = recip
End Function
 
 
Sub InsertSignature(objMail As MailItem, SignatureName As String)
'---------------------------------------------------------------------------------------
' Procedure : InsertSignature
' Author    : OLiv
' Version   : 2
' Date      : 09/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, strSigFilePath
    Const wdStory = 6
    Const wdParagraph = 4
    Const wdGoToBookmark = -1
    Const wdExtend = 1
    Const wdSortByName = 0
    enviro = CStr(Environ("appdata"))
    strSigFilePath = enviro & "\Microsoft\Signatures\"
 
 
    Set wd = objMail.GetInspector.WordEditor
 
    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
        Set obSelection = wd.Application.Selection
        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
End Sub

**Oliv-** · 16/06/2020, 08h58

Bonjour,
et y a t'il des messages ou des erreurs ?

**antony34200** · 16/06/2020, 13h51

Bonjour,
aucun message d'erreur.
je crois que je vais me contenter d'avoir la signature automatique en fonction de l'objet ... l'import des PJ je les ferais manuellement ...

**Oliv-** · 16/06/2020, 13h56

Pour y voir plus clair tu dois déboguer le code en utilisant le mode pas à pas F8

Tu verras où il passe dans les boucles et conditions

vois tu les MSgbox où c'est indiqué la chane de caractère recherchée ?
le dossier est -il bien noté

**antony34200** · 16/06/2020, 13h59

Je viens de faire alt+F11 pour ouvrir le code, je fais ensuite F8, et rien ne se passe

**antony34200** · 16/06/2020, 14h03

je viens de redémarer OL.
Alt+F11 puis F8

Se surligne en jaune :

Code :

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

1
2
3
4
5
Private Sub maj_signature_et_PJ()
 On Error Resume Next
Set item = ActiveInspector.CurrentItem
If item Is Nothing Then
MsgBox "pas de nouveau Email !", vbCritical

puis j'ai une fenêtre avec une croix rouge, pas de nouveau mail !

puis se surligne en jaune :

Code :

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

: End

et de nouveau on repasse à

Code :

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

Private Sub maj_signature_et_PJ()

**Oliv-** · 16/06/2020, 14h05

il faut créer au préalable un email avec un destinataire et le sujet avant de lancer la macro par F8

**antony34200** · 16/06/2020, 14h12

ok
voila se que sa donne
1. saisie de l'adresse mail
2. saisie de l'objet puis tabulation

puis
1. F8 = rien
2. F8 = Grisage au niveau du corps de mail
3. F8 = Grisage de ma signature par défaut
puis tapotage (20 fois environ) sur F8 et plus rien ne se passe

**Oliv-** · 16/06/2020, 14h26

pour lancer par F8 la macro il faut être dans l'éditeur de macro et que le curseur clignote dans la macro

**antony34200** · 16/06/2020, 14h30

j'ai une fenetre qui c'est ouverte.

Recherche PJ pour

Pénom = le nom de mon contact
Nom = le prenom de mon contact
Pérnomnom@gmail.com

-->[Prénom N]