[OL-365] Publipostage de masse personnalisé

Bonjour, j'ai trouvé un code qui me permet d'envoyé des pièce jointe à plusieurs destinataire. Par contre j'aimerais modifier le code pour qu'il cherche les pièces jointes dans un dossier précis ayant dans le nom l'adresse courriel du destinataire Je vous remercie d'avance pour votre aide.

Voici le code en question :

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
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
 
'Pour publipostage avec
'PJ OUTLOOK IDENTIQUE POUR TOUS LES MAILS
'ou INDIVIDUELLE PAR DESTINAIRE
'ou ENVOI DE MAIL INDIVIDUALISES EN GROUPE A UNE MEME ADRESSE MAIL
 
Dim objFolder As Object
Dim objFile As Object
 
If Item.Class = olMail Then
Dim objCurrentMessage As MailItem
Set objCurrentMessage = Item
If UCase(objCurrentMessage.Subject) Like "*PUBLIIDEM*" Then
    On Error Resume Next
    'Pour ajouter la même PJ à tous
    Dim i As Long
    i = 0
    If publipostagePJ <> "" Then
        While publipostagePJ(i) <> "fin"
            objCurrentMessage.Attachments.Add Source:=publipostagePJ(i)
            i = i + 1
        Wend
    End If
 
    'On supprime le terme PUBLIIDEM du sujet
    objCurrentMessage.Subject = Replace(objCurrentMessage.Subject, "PUBLIIDEM ", "")
ElseIf UCase(objCurrentMessage.Subject) Like "*PUBLIPERSO*" Then
        'Pour ajouter une ou des PJ personalisées contenant l'adresse email dans leur nom
        'déclaration du scripting.filesystemobjet pour parcourir les dossiers
        Set objFSO = CreateObject("Scripting.FileSystemObject")
 
        '----------------On précise le chemin du dossier contenant les documents sans oublier l'\ à la fin --------------
        Set objFolder = objFSO.GetFolder("C:\Users\TheBa\OneDrive\Bureau\Test publipostage\Publi test 2\")
 
        'parcours chaque fichier du dossier
        For Each objFile In objFolder.Files
            ' test pour savoir si le nom contient l'email du destinataire et l'ajoute en PJ
            If objFile.Name Like "*" & objCurrentMessage.To & "*" Then
                objCurrentMessage.Attachments.Add Source:=objFile.Path
            End If
        Next objFile
 
        'On supprime le terme PUBLIPERSO du sujet
        objCurrentMessage.Subject = Replace(objCurrentMessage.Subject, "PUBLIPERSO ", "")
        'On sauvegarde le mail
        objCurrentMessage.Save
    End If
    Set objCurrentMessage = Nothing
End If
End Sub