Insérer une signature dans un vba

Sub envoi_recap() NB_Mail = Sheets("Mail").Cells(Rows.Count, 1).End(xlUp).Row Dim WorkRng As Range On Error Resume Next Sheets("Mail").Activate ' Récupérer le nom du fichier de signature sPath = "C:\Users\toto\AppData\Roaming\Microsoft\Signatures\" SigString = Dir(sPath & "societe.htm") If SigString <> "" Then Signature = sPath & SigString Else Signature = "" Set WorkRng = Sheets("mail").Range("A1:D" & NB_Mail) & Signature Application.ScreenUpdating = False WorkRng.Select ActiveWorkbook.EnvelopeVisible = True With ActiveSheet.MailEnvelope .Item.To = Sheets("sommaire").Range("G1") .Item.CC = Sheets("sommaire").Range("G2") .Item.Subject = Sheets("sommaire").Range("G3") .Item.Send End With Application.ScreenUpdating = True End Sub

Voici la solution que j'ai appliqué :

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
 
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
 
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
 
    NB_Mail = Sheets("Mail").Cells(Rows.Count, 1).End(xlUp).Row
    Set rng = Nothing
    Set rng = Sheets("mail").Range("A1:D" & NB_Mail)   'On définit la plage de données à convertir en HTML
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    OutMail.display 'affiche le message avec la signature par défaut
    OutMail.to = mailto
 
    On Error Resume Next
    With OutMail
        .to = Sheets("sommaire").Range("G1")
        .CC = Sheets("sommaire").Range("G2")
        .BCC = Range("")
        .Subject = Sheets("sommaire").Range("G3")
        .HTMLBody = RangetoHTML(rng) & "<br>" & .HTMLBody 'On appelle la fonction RangetoHTML qui va convertir la plage en données HTML et on ajoute la signature
        .display
        .Send '.Save pour sauvegarder le mail dans les brouillons, .send pour l'envoyer'
    End With
    On Error GoTo 0
    With Application
        .EnableEvents = True
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub