Microsoft 365 Publipostage de masse avec pièce jointe personnalisé avec outlook

[Sebast6945]

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 vérifie si l'adresse courriel du destinataire est dans la nom de la pièce jointe plutôt que de vérifier si le nom du destinataire est dans la pièce jointe. Je vous remercie d'avance pour votre aide.

Voici le code en question :

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

 

[Sebast6945]

Pour précision, j'aimerais que le code cherche les pièces jointes dans un dossier précis ayant dans le nom l'adresse courriel du destinataire.