Signature mail avec Outlook

Bonjour,

J'aimerai intégrer ma signature dans mon mail outlook à partir d'un fichier excel.

Pour essayer de palier à mon probleme, j'avais activé depuis outlook, l'intégration de ma signature à la rédaction dans nouveau mail.

Cependant quand ma macro vient ouvrir un nouveau mail... je n'ai pas ma signature, voici mon code:

Sub Mail()

Const olMailItem = 0

Dim sBody As String
Dim Body1 As Object
Dim Destinataire As String
Dim Autres_Destinataires As String
Dim Objet_mail As String
Dim outlookApp As Object
Set outlookApp = CreateObject("Outlook.Application")
Dim outMail As Object
Set outMail = outlookApp.CreateItem(olMailItem)
Destinataire = "l;" & _
                ";" & _
                ""
Autres_Destinataires = "..."

With outMail
.HtmlBody = sBody
    .To = Destinataire
    .CC = Autres_Destinataires
    .Subject = " "
    .display
End With

End Sub

Auriez-vous une solution ?

Vous remerciant par avance ,

Bonjour,

Voici un exemple qui fonctionne. Je l'utilise tous les jours. Il n'est pas de moi mais adapté à mon besoin.

Appel du module :

    Dim expediteur As String
    Dim destinataireaction As String
    Dim destinataireinfo As String
    Dim tableau As Range
    Dim objet As String

Set tableau = Sheets("onglet contenant le tableau a envoyer").Range("b3:q22")
objet = "Objet du mail"

Call envoimail2(destinataireaction, destinataireinfo, tableau, expediteur, objet)

Puis j'ai créé un module contenant le code suivant :

Option Explicit
' Déclaration en tout début de module
Dim OlApp As Object, eMails As Object
' Création d'une instance Outlook en Late Binding
' Il faut déclarer les constantes nécessaires
Const OlFolderSentMail As Long = 5
Const olMailItem = 0

Public Sub envoimail2(ByVal destinataireaction As String, ByVal destinataireinfo As String, ByRef tableau As Range, ByVal expediteur As String, ByVal objet As String)
  Dim rng As Range

  Set OlApp = CreateObject("Outlook.Application")  'création instance application outlook
  Set eMails = OlApp.Session.GetDefaultFolder(OlFolderSentMail).Items   'assignation évènements éléments envoyés

  Set rng = tableau

  With OlApp.CreateItem(olMailItem)
    .Display  ' Afficher le mail pour la signature (à mettre absolument sinon pas de signature)
    '
    .Subject = objet
 '   .Item.SentOnBehalfOfName = expediteur
    .To = destinataireaction

    .Cc = destinataireinfo

    .HTMLBody = RangetoHTML(rng) & .HTMLBody

  .Send
  End With

  '
  ' Vider les variables objet

  Set OlApp = Nothing
  Set eMails = Nothing
End Sub

Function RangetoHTML(rng As Range)

    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Voila ce que j'utilise.

Bonsoir,

ci-dessous code avec signature automatique

Sub Mail()

    Dim sBody As String
    Dim Destinataire As String
    Dim Autres_Destinataires As String
    Dim Objet_mail As String
    Dim OL As Object, myItem As Object, wDoc As Object, rng As Object

    Destinataire = "l;" & _
                    ";" & _
                    ""
    Autres_Destinataires = "..."

    Set OL = CreateObject("Outlook.Application")
    Set myItem = OL.CreateItem(olMailItem)
    Set wDoc = myItem.GetInspector.WordEditor
    Set rng = wDoc.Content

    With myItem
        ' adresse des destinataires, en copie, objet du mail
        .To = Destinataire
        .CC = Autres_Destinataires
        .Subject = Objet_mail
        .Display

        ' Corps du mail
        rng.InsertBefore sBody
        rng.Start = rng.Start + Len(sBody)
        rng.InsertBefore vbNewLine & vbNewLine
        rng.MoveStart unit:=1, Count:=2

        ' Formule de politesse
        rng.InsertBefore "Cordialement"

        ' Envoi mail
        .Send
    End With

    Set OL = Nothing

End Sub

Bonjour à tous,

Merci beaucoup pour vos 2 réponses elles fonctionnent toutes parfaitement!

Belle fin de journée à vous,