Ajouter automatiquement la signature Outlook à un e-mail généré par VBA

Le 26/02/2025 à 16:05

Bonjour à tous,

Je travaille sur une macro VBA qui capture des plages de cellules Excel sous forme d’images, puis les insère dans un e-mail Outlook généré automatiquement. L’e-mail contient du texte introductif, les images, et je voudrais que la signature Outlook de l’expéditeur soit ajoutée automatiquement à la fin du message.

J'ai essayé avec une ia de le rajouter mais ca ne marche pas.

Mon code ci-dessous :

Sub CaptureEtInsererDeuxImages()

Dim ws1 As Worksheet, ws2 As Worksheet

Dim Plage1 As Range, Plage2 As Range

Dim ChartTemp1 As ChartObject, ChartTemp2 As ChartObject

Dim objOutlook As Object ' Utilisation de Late Binding

Dim objMail As Object ' Utilisation de Late Binding

Dim objInspector As Object

Dim objDoc As Object

Dim objRange As Object

Dim objSelection As Object

Dim objShape As Object ' Remplace InlineShape pour éviter l'erreur

Dim imgPath1 As String, imgPath2 As String

Dim TexteIntro As String, TexteIntermediaire As String, ObjetMail As String

Dim DateReference As Date, DateFormattee As String

' Déterminer la date de référence

If Weekday(Date, vbMonday) = 1 Then ' Si aujourd'hui est lundi

DateReference = Date - 2 ' Prendre la date du samedi précédent

Else

DateReference = Date - 1 ' Sinon, prendre la date d'hier

End If

' Formater la date en "JJ/MM/AA"

DateFormattee = Format(DateReference, "dd/mm/yy")

' Définir les textes

TexteIntro = "Bonjour," & vbNewLine & vbNewLine & _

"Ci-dessous les anomalies Méca par ligne d'injection du " & DateFormattee & ":" & vbNewLine & vbNewLine

TexteIntermediaire = "Ci-dessous le détail des pertes tracking par heure et par cellule :" & vbNewLine & vbNewLine

' Définir l'objet du mail

ObjetMail = "FRAIS - Anomalie Méca par ligne d'injection du " & DateFormattee

' Définir les feuilles et plages à capturer

Set ws1 = ThisWorkbook.Sheets("TCD")

Set Plage1 = ws1.Range("A1:S30")

Set ws2 = ThisWorkbook.Sheets("Cellules")

Set Plage2 = ws2.Range("A1:Y30")

' Définir les chemins des images temporaires

imgPath1 = Environ("TEMP") & "\Capture1.png"

imgPath2 = Environ("TEMP") & "\Capture2.png"

' Supprimer les images temporaires précédentes si elles existent

If Dir(imgPath1) <> "" Then Kill imgPath1

If Dir(imgPath2) <> "" Then Kill imgPath2

' Capture et enregistrement des images

ws1.Activate

Set ChartTemp1 = ws1.ChartObjects.Add(Left:=0, Width:=Plage1.Width, Top:=1000, Height:=Plage1.Height)

Plage1.CopyPicture Appearance:=xlScreen, Format:=xlPicture

ChartTemp1.Activate

Application.Wait Now + TimeValue("00:00:01")

ChartTemp1.Chart.Paste

ChartTemp1.Chart.Export Filename:=imgPath1, FilterName:="PNG"

ChartTemp1.Delete

ws2.Activate

Set ChartTemp2 = ws2.ChartObjects.Add(Left:=0, Width:=Plage2.Width, Top:=1000, Height:=Plage2.Height)

Plage2.CopyPicture Appearance:=xlScreen, Format:=xlPicture

ChartTemp2.Activate

Application.Wait Now + TimeValue("00:00:01")

ChartTemp2.Chart.Paste

ChartTemp2.Chart.Export Filename:=imgPath2, FilterName:="PNG"

ChartTemp2.Delete

' Vérifier si les images ont bien été générées

If Dir(imgPath1) = "" Or Dir(imgPath2) = "" Then

MsgBox "Erreur : Une ou plusieurs images n'ont pas été créées.", vbCritical

Exit Sub

End If

' Créer un nouvel e-mail Outlook avec Late Binding

Set objOutlook = CreateObject("Outlook.Application")

Set objMail = objOutlook.CreateItem(0)

' Définir l'objet et les destinataires du mail

objMail.Subject = ObjetMail

objMail.To = "x"

objMail.CC = "x"

objMail.Display

' Insérer le texte et les images dans le bon ordre

Set objInspector = objMail.GetInspector

Set objDoc = objInspector.WordEditor

Set objRange = objDoc.Range

' Insérer le texte d'introduction

objRange.Text = TexteIntro

objRange.Collapse 0

objRange.Text = vbNewLine & vbNewLine ' Ajout de saut de ligne avant l'image

' Insérer la première image juste après le texte d'introduction

Set objShape = objRange.InlineShapes.AddPicture(imgPath1, False, True)

objShape.LockAspectRatio = False

objShape.Width = 800 ' Ajuster selon besoin

objShape.Height = 500 ' Ajuster selon besoin

' Ajouter un saut de ligne après l'image 1

objRange.Collapse 0

objRange.Text = vbNewLine & vbNewLine

' Insérer le texte intermédiaire après l'image 1

objRange.Collapse 0

objRange.Text = TexteIntermediaire

objRange.Collapse 0

objRange.Text = vbNewLine & vbNewLine ' Ajout de saut de ligne avant l'image 2

' Insérer la deuxième image après le texte intermédiaire

Set objShape = objRange.InlineShapes.AddPicture(imgPath2, False, True)

objShape.LockAspectRatio = False

objShape.Width = 800 ' Ajuster selon besoin

objShape.Height = 500 ' Ajuster selon besoin

' Ajouter un saut de ligne après l'image 2

objRange.Collapse 0

objRange.Text = vbNewLine & vbNewLine

' Insérer la signature automatique d'Outlook

On Error Resume Next

Set objSelection = objDoc.Application.Selection

objSelection.EndKey Unit:=6 ' Aller à la fin du document

objSelection.TypeParagraph ' Ajouter un saut de ligne

objSelection.InsertParagraphAfter

objSelection.MoveDown Unit:=5, Count:=1 ' Déplacer le curseur

objSelection.InsertParagraphAfter

objSelection.MoveDown Unit:=5, Count:=1

objSelection.InsertAutoText

On Error GoTo 0

' Nettoyage des objets

Set objRange = Nothing

Set objDoc = Nothing

Set objInspector = Nothing

Set objMail = Nothing

Set objOutlook = Nothing

Set ChartTemp1 = Nothing

Set ChartTemp2 = Nothing

Set ws1 = Nothing

Set ws2 = Nothing

Set Plage1 = Nothing

Set Plage2 = Nothing

Set objSelection = Nothing

End Sub.

En vous souhaitant bonne réception et merci d'avance :)

Le 02/03/2025 à 12:23

Bonjour Nicotine31

Je pense que vous êtes passé à côté de l'excellent site de Ron de Bruin

Vous devriez trouver votre bonheur ICI

A+

Le 04/03/2025 à 17:33

Bonjour,

Tout d'abord un rappel. Pour l'insertion de code, utiliser la balise :</>

ci-dessous code avec insertion de signature

Sub CaptureEtInsererDeuxImages()

    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim Plage1 As Range, Plage2 As Range
    Dim ChartTemp1 As ChartObject, ChartTemp2 As ChartObject
    Dim objOutlook As Object ' Utilisation de Late Binding
    Dim objMail As Object ' Utilisation de Late Binding
    Dim objInspector As Object
    Dim objDoc As Object
    Dim objRange As Object
    Dim objSelection As Object
    Dim objShape As Object ' Remplace InlineShape pour éviter l'erreur
    Dim imgPath1 As String, imgPath2 As String
    Dim TexteIntro As String, TexteIntermediaire As String, ObjetMail As String
    Dim DateReference As Date, DateFormattee As String
    Dim position_sig As Long, position_fin As Long
    Dim rng As Object

    ' Déterminer la date de référence
    If Weekday(Date, vbMonday) = 1 Then ' Si aujourd'hui est lundi
        DateReference = Date - 2 ' Prendre la date du samedi précédent
    Else
        DateReference = Date - 1 ' Sinon, prendre la date d'hier
    End If

    ' Formater la date en "JJ/MM/AA"
    DateFormattee = Format(DateReference, "dd/mm/yy")

    ' Définir les textes
    TexteIntro = "Bonjour," & vbNewLine & vbNewLine & _
    "Ci-dessous les anomalies Méca par ligne d'injection du " & DateFormattee & ":" & vbNewLine & vbNewLine
    TexteIntermediaire = "Ci-dessous le détail des pertes tracking par heure et par cellule :" & vbNewLine & vbNewLine

    ' Définir l'objet du mail
    ObjetMail = "FRAIS - Anomalie Méca par ligne d'injection du " & DateFormattee

    ' Définir les feuilles et plages à capturer
    Set ws1 = ThisWorkbook.Sheets("TCD")
    Set Plage1 = ws1.Range("A1:S30")
    Set ws2 = ThisWorkbook.Sheets("Cellules")
    Set Plage2 = ws2.Range("A1:Y30")

    ' Définir les chemins des images temporaires
    imgPath1 = Environ("TEMP") & "\Capture1.png"
    imgPath2 = Environ("TEMP") & "\Capture2.png"

    ' Supprimer les images temporaires précédentes si elles existent
    If Dir(imgPath1) <> "" Then Kill imgPath1
    If Dir(imgPath2) <> "" Then Kill imgPath2

    ' Capture et enregistrement des images
    ws1.Activate
    Set ChartTemp1 = ws1.ChartObjects.Add(Left:=0, Width:=Plage1.Width, Top:=1000, Height:=Plage1.Height)
    Plage1.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    ChartTemp1.Activate
    Application.Wait Now + TimeValue("00:00:01")
    ChartTemp1.Chart.Paste
    ChartTemp1.Chart.Export Filename:=imgPath1, FilterName:="PNG"
    ChartTemp1.Delete

    ws2.Activate
    Set ChartTemp2 = ws2.ChartObjects.Add(Left:=0, Width:=Plage2.Width, Top:=1000, Height:=Plage2.Height)
    Plage2.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    ChartTemp2.Activate
    Application.Wait Now + TimeValue("00:00:01")
    ChartTemp2.Chart.Paste
    ChartTemp2.Chart.Export Filename:=imgPath2, FilterName:="PNG"
    ChartTemp2.Delete

    ' Vérifier si les images ont bien été générées
    If Dir(imgPath1) = "" Or Dir(imgPath2) = "" Then
        MsgBox "Erreur : Une ou plusieurs images n'ont pas été créées.", vbCritical
        Exit Sub
    End If

    ' Créer un nouvel e-mail Outlook avec Late Binding
    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)

    ' Définir l'objet et les destinataires du mail
    objMail.Subject = ObjetMail
    objMail.To = "x"
    objMail.CC = "x"
    objMail.Display     'insertion de la signature

    ' Insérer le texte et les images dans le bon ordre
    Set objInspector = objMail.GetInspector
    Set objDoc = objInspector.WordEditor
    Set objRange = objDoc.Range
    position_sig = objRange.End  'position de fin avec la signature

    ' Insérer le texte d'introduction
    position_fin = objRange.End
    Set rng = objDoc.Range(position_fin - position_sig, position_fin - position_sig)
    rng.InsertAfter TexteIntro & vbNewLine & vbNewLine

    ' Insérer la première image juste après le texte d'introduction
    position_fin = objRange.End
    Set rng = objDoc.Range(position_fin - position_sig, position_fin - position_sig)
    Set objShape = rng.InlineShapes.AddPicture(imgPath1, False, True)
    objShape.LockAspectRatio = False
    objShape.Width = 800 ' Ajuster selon besoin
    objShape.Height = 500 ' Ajuster selon besoin

    ' Insérer le texte intermédiaire après l'image 1
    position_fin = objRange.End
    Set rng = objDoc.Range(position_fin - position_sig, position_fin - position_sig)
    rng.InsertAfter vbNewLine & vbNewLine & TexteIntermediaire & vbNewLine & vbNewLine

    ' Insérer la deuxième image après le texte intermédiaire
    position_fin = objRange.End
    Set rng = objDoc.Range(position_fin - position_sig, position_fin - position_sig)
    Set objShape = rng.InlineShapes.AddPicture(imgPath2, False, True)
    objShape.LockAspectRatio = False
    objShape.Width = 800 ' Ajuster selon besoin
    objShape.Height = 500 ' Ajuster selon besoin

    ' Ajouter un saut de ligne après l'image 2
    position_fin = objRange.End
    Set rng = objDoc.Range(position_fin - position_sig, position_fin - position_sig)
    rng.InsertAfter vbNewLine & vbNewLine

    On Error Resume Next

    Set objSelection = objDoc.Application.Selection
    objSelection.EndKey Unit:=6 ' Aller à la fin du document
    objSelection.TypeParagraph ' Ajouter un saut de ligne
    objSelection.InsertParagraphAfter
    objSelection.MoveDown Unit:=5, Count:=1 ' Déplacer le curseur
    objSelection.InsertParagraphAfter
    objSelection.MoveDown Unit:=5, Count:=1
    objSelection.InsertAutoText

    On Error GoTo 0

    ' Nettoyage des objets
    Set objRange = Nothing
    Set objDoc = Nothing
    Set objInspector = Nothing
    Set objMail = Nothing
    Set objOutlook = Nothing
    Set ChartTemp1 = Nothing
    Set ChartTemp2 = Nothing
    Set ws1 = Nothing
    Set ws2 = Nothing
    Set Plage1 = Nothing
    Set Plage2 = Nothing
    Set objSelection = Nothing

End Sub
Rechercher des sujets similaires à "ajouter automatiquement signature outlook mail genere vba"