Microsoft 365 Personnaliser l'objet dans envoi mails

[phil75016]

Bonjour
J'ai trouvé sur un autre site (https://xlbusinesstools.com/envoyer-emails-excel-outlook/) une macro que j'ai adaptée et qui permet d'envoyer des mails à partir d'excel. Elle fonctionne correctement mais ce que je souhaiterais si c'est possible c'est de personnaliser l'objet pour chaque mail en ajoutant devant l'objet pré-défini en cellule B3 de l'onglet "Mail" le code qui figure dans la colonne A de la feuille "Liste d'envoi".
Exemple : "A003 - Test envoi mail" pour l'envoi de la première ligne
puis "A009 - Test envoi mail" pour l'envoi de la seconde ligne.
SI je ne suis pas assez clair merci de me le dire.

Merci à tous.

 

[Lolote83]

Bonjour Phil75016,
pourquoi ne pas créér une variable tableau comme tabCodeSociété ou tu lui affecterais :
tabCodeSociété = Sheets("Liste d'envoi").Range("A3:A" & derniere_ligne).Value
et lors de l'appel à la procédure CreatenewMessage, tu rajoutes dans les paramètrres strCodeSociété et du coup, ton .Subject deviendrait .Subject = strCodeSociété & "-" & sSubject

Option Explicit
Private OL_App As Object
Private OL_Mail As Object
Private sSubject As String, sBody As String


Sub SendDocuments()
' Generate e-mails to be sent to a list of mail recipients, with a customized attachment and message for each person

Dim i As Long
Dim tabContactNames As Variant, tabContactEmails As Variant, tabFNames As Variant, tabFNames2 As Variant, tabFNames3 As Variant, derniere_ligne
Dim tabCodeSociété As Variant

' Init
Application.ScreenUpdating = False
' Open Outlook
On Error Resume Next
Set OL_App = GetObject(, "Outlook.Application")
If OL_App Is Nothing Then
    Set OL_App = CreateObject("Outlook.Application")
End If

On Error GoTo 0
' Read E-mail parameters
    sSubject = Sheets("Mail").Range("B3").Value
    sBody = Sheets("Mail").Range("B5").Value

'trouver la dernière ligne
    derniere_ligne = Sheets("Liste d'envoi").Range("A500").End(xlUp).Row
    
' Read Contact list
    tabCodeSociété = Sheets("Liste d'envoi").Range("A3:A" & derniere_ligne).Value


    tabContactNames = Sheets("Liste d'envoi").Range("C3:C" & derniere_ligne).Value
    tabContactEmails = Sheets("Liste d'envoi").Range("D3:D" & derniere_ligne).Value
    
    'Fichiers dossiers_comptables
    tabFNames = Sheets("Liste d'envoi").Range("E3:E" & derniere_ligne).Value
    
    'Fichiers dossiers fiscaux:
    tabFNames2 = Sheets("Liste d'envoi").Range("f3:F" & derniere_ligne).Value
    
   'Fichiers ANNEXES:
    tabFNames3 = Sheets("Liste d'envoi").Range("g3:g" & derniere_ligne).Value

' Generate e-mails
For i = 1 To UBound(tabContactNames, 1)


If tabContactNames(i, 1) <> vbNullString Then
    Call CreateNewMessage(tabContactNames(i, 1), tabContactEmails(i, 1), tabFNames(i, 1), tabFNames2(i, 1), tabFNames3(i, 1), tabCodeSociété(i, 1))
End If

Next i

    MsgBox "The process has been entirely completed."

Set OL_App = Nothing
Set OL_Mail = Nothing
Application.ScreenUpdating = True

End Sub


Private Sub CreateNewMessage(strContactName, strContactTo, strFName, strFName2, strFName3, strCodeSociété)
' Create a new message with the following inputs :
Set OL_Mail = OL_App.CreateItem(0)

With OL_Mail
    .To = strContactTo
    '.CC = "alias1@domain1.com"
    '.BCC = "alias2@domain1.com"
     .Subject = strCodeSociété & "-" & sSubject
     .Body = sBody
     .BodyFormat = 2 'Format : 0=undetermined; 1=plain text; 2= HTML; 3=rich text
     .Importance = 2 'Importance : 0=low; 1=normal; 2= high
     .Sensitivity = 0 'Confidentiality : 0=normal; 1=personal; 2=private; 3=confidential
     .Attachments.Add (strFName)
     .Attachments.Add (strFName2)
     .Attachments.Add (strFName3)
     'adresse mail de l'expéditeur :
     .SentOnBehalfOfName = Sheets("Mail").Range("B4").Value
    
    ' Sélectionner Display si on veut voir le message avant qu'il soit envoyé ou .send si on veut qu'il parte directement
     '.Display
     .Send
End With

    Set OL_Mail = Nothing

End Sub

@+ Lolote83

 

[phil75016]

Merci Lolote83 c'est exactement ce qu'il me faut. Bonne journée.