Add outlook signature with excel VBA

Question

Here's my code. It all works really well but i can't manage to find how to add automatically the only signature I have in outlook. Even chat-gpt 4 doesn't find the answer. If a real warrior is out there with the solution please explain it to me. Thank you and have a nice day!

Sub CreerBrouillonOutlook()

Dim OutlookApp As Object
Dim OutlookMail As Object
Dim ws As Worksheet
Dim wsListeEnvoi As Worksheet
Dim i As Long
Dim derniereligne As Long
Dim destinataires As String
Dim destinatairesDico As Object
Dim destinatairesCC As String
Dim destinatairesCCDico As Object
Dim derniereLigneUtilisateur As Long
Dim message As String

' Spécifiez la feuille de calcul active
Set ws = ActiveSheet

' Obtenez le numéro de la dernière ligne avec des données
derniereligne = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

' Crée une instance d'Outlook
Set OutlookApp = CreateObject("Outlook.Application")

' Crée un dictionnaire pour stocker les destinataires uniques
Set destinatairesDico = CreateObject("Scripting.Dictionary")

' Crée un dictionnaire pour stocker les destinataires CC uniques
Set destinatairesCCDico = CreateObject("Scripting.Dictionary")

' Feuille "Liste d'envoi"
Set wsListeEnvoi = ThisWorkbook.Sheets("Liste d'envoi")

' Boucle à travers chaque ligne dans la colonne des responsables (par exemple, colonne B)
For i = 8 To derniereligne
    ' Vérifiez si les deux premières lettres de la cellule de la colonne P sont "1 " ou "6 "
    If (Left(ws.Cells(i, 16).Value, 2) = "1 " Or Left(ws.Cells(i, 16).Value, 2) = "6 ") _
        And (ws.Cells(i, 1).Interior.Color = RGB(255, 255, 255) Or ws.Cells(i, 1).Interior.Color = RGB(255, 153, 204)) Then

        ' Vérifiez si l'adresse e-mail est présente dans la colonne B
        If ws.Cells(i, 18).Value <> "" Then
            ' Utilisez la fonction Replace pour traiter les noms séparés par des barres verticales
            Dim nomsAvecBarreVerticale As String
            nomsAvecBarreVerticale = Replace(ws.Cells(i, 18).Value, " | ", ";")
            
            ' Utilisez la fonction Split pour traiter les noms séparés par des points-virgules
            Dim noms As Variant
            noms = Split(nomsAvecBarreVerticale, ";")
            
            ' Ajoutez chaque nom au dictionnaire après le remplacement
            Dim nom As Variant
            For Each nom In noms
                nom = Trim(nom) ' Supprimez les espaces éventuels
                If Not destinatairesDico.Exists(nom) Then
                    destinatairesDico.Add nom, nom
                End If
            Next nom
        End If
    End If
Next i

' Boucle à travers chaque ligne dans la colonne D de la feuille "Liste d'envoi"
i = 4
Do While wsListeEnvoi.Cells(i, 4).Value <> "" ' Continue jusqu'à la première ligne vide dans la colonne D
    ' Vérifiez si l'adresse e-mail est présente dans la colonne D
    If wsListeEnvoi.Cells(i, 4).Value <> "" Then
        ' Ajoutez chaque destinataire CC au dictionnaire
        Dim destinataireCC As String
        destinataireCC = Trim(wsListeEnvoi.Cells(i, 4).Value)
        If Not destinatairesCCDico.Exists(destinataireCC) Then
            destinatairesCCDico.Add destinataireCC, destinataireCC
        End If
    End If
    i = i + 1
Loop

' Construire le message à partir des colonnes E et F de la feuille "Liste d'envoi"
message = "Bonjour, " & vbCrLf & vbCrLf & _
          "" & wsListeEnvoi.Cells(5, 5).Value & vbCrLf & _
          "" & wsListeEnvoi.Cells(4, 6).Value & vbCrLf & _
          "" & wsListeEnvoi.Cells(6, 5).Value & vbCrLf & _
          "" & wsListeEnvoi.Cells(5, 6).Value & vbCrLf & vbCrLf _

' Crée une instance d'un nouvel e-mail
Set OutlookMail = OutlookApp.CreateItem(0)

' Spécifiez le sujet et le corps du courriel
OutlookMail.Subject = ws.Cells(1, 1).Value ' Utilisez la première ligne de la colonne A comme sujet
OutlookMail.Body = message

' Ajoutez les destinataires uniques au champ "À"
OutlookMail.To = Join(destinatairesDico.Items, ";")

' Ajoutez les destinataires CC uniques au champ "CC"
OutlookMail.CC = Join(destinatairesCCDico.Items, ";")

' Ajoutez le document actuel en pièce jointe
OutlookMail.Attachments.Add ActiveWorkbook.FullName

' Affichez le brouillon dans Outlook
OutlookMail.Display

' Libérer la mémoire
Set OutlookApp = Nothing
Set OutlookMail = Nothing
Set destinatairesDico = Nothing
Set destinatairesCCDico = Nothing

End Sub

gpt4 and didnt work. I expect to see my signature