Microsoft 365 Envoi par mail d'un tcd

DR85

XLDnaute Junior
Bonjour,

Je souhaiterais rendre "automatique" l'envoi par mail un tcd (idéalement en capture ou alors fichier joint). Avec bouton lié a une macro.
Problème, lorsque j'active la macro le mail s'ouvre avec la copie du tcd mais le corps du message ne s'affiche pas. Je ne comprends pas pourquoi.
Si possible le corps du message devra être en calibri taille 11. Je souhaiterais également mettre une signature pré enregistrée.
Pourriez vous m'aider svp?

Damien
 

Pièces jointes

  • Copie de Extraction version DR.xlsm
    50.4 KB · Affichages: 13

fanch55

XLDnaute Barbatruc
Une proposition:
VB:
Sub EnvoyerTCDparMail()
   Dim TCD          As PivotTable
   Dim Mail         As Object
   Dim Destinataire As String
 
   Set TCD = ActiveSheet.PivotTables("tcd1")
   If TCD Is Nothing Then
       MsgBox "Le tableau croisŽ dynamique 'tableau croisŽ 1' n'existe pas sur la feuille active.", vbExclamation
       Exit Sub
   End If
   
   Dim Signature:  Signature = "Moi Gmail"                     ' Nom d'une signature établie dans Outlook
   Dim Mailbox:    Mailbox = "Test.Vba@gmail.com"  ' Compte de Messagerie

    With CreateObject("Outlook.Application")
        ' Sélection du compte Mailbox dans outlook
        For Each Elem In .Session.Accounts
            If Elem = Mailbox Then Set Account = Elem: Exit For
        Next
        If Account Is Nothing Then MsgBox Mailbox & " non trouvé", vbCritical: Exit Sub
        Signature = GetSig(Signature) ' Récupération de la signature si elle existe
       
        Set Mail = .CreateItem(0)
        With Mail
            .Subject = "Commandes en retard d'expŽdition"
            .To = Destinataire
            .Cc = Destinataire
            .htmlbody = "<html><body><p>Bonjour,</p><br>" & _
                        "<p>Voici l'Žtat des commandes en retard d'expŽdition.</p>"
            .Display
            Set Wedi = .GetInspector.wordeditor
                Wedi.Content.InsertParagraphAfter ' paragraphe en fin
                TCD.TableRange2.CopyPicture Appearance:=xlScreen, Format:=xlPicture
                Wedi.Paragraphs(Wedi.Paragraphs.Count).Range.Paste
                Wedi.Content.InsertParagraphAfter
            Set Wedi = Nothing
                               
            .htmlbody = .htmlbody & _
                        "<p>Bien cordialement,</p>" & _
                        "</Body>" & Signature
        End With
    End With

   Set Mail = Nothing
   Set TCD = Nothing
End Sub
Function GetSig(ByVal Signature As String) As String
Dim Fso As Object
Dim Txs As Object
Dim File As String
    Set Fso = CreateObject("Scripting.FileSystemObject")
        File = Environ("appdata") & "\Microsoft\Signatures\" & Signature & ".htm"
        Select Case True
            Case Signature = "":
            Case Not Fso.FileExists(File):
            Case Else
                Set Txs = Fso.GetFile(File).OpenAsTextStream(1, -2)
                    GetSig = Txs.ReadAll
                    Txs.Close
                Set Txs = Nothing
        End Select
    Set Fso = Nothing
End Function
 
Dernière édition:

DR85

XLDnaute Junior
Fanch55,
Merci beaucoup pour votre réponse. Globalement ça correspond à mes attentes. :)

Serait il possible d’augmenter de 15% la taille du tcd et de l’insérer après Cordialement et la signature? Chez moi la signature n´apparait pas. Pourtant j’ai bien renseigné son nom dans le code...
Cordialement
 

fanch55

XLDnaute Barbatruc
Serait il possible d’augmenter de 15% la taille du tcd et de l’insérer après Cordialement et la signature?
VB:
Sub EnvoyerTCDparMail()
   Dim TCD          As PivotTable
   Dim Mail         As Object
   Dim Wedi         As Object
   Dim Destinataire As String
   Dim Account      As Object
 
   Set TCD = ActiveSheet.PivotTables("tcd1")
   If TCD Is Nothing Then
       MsgBox "Le tableau croisŽ dynamique 'tableau croisŽ 1' n'existe pas sur la feuille active.", vbExclamation
       Exit Sub
   End If
  
   Dim Signature:  Signature = "Moi Gmail"                     ' Nom d'une signature établie dans Outlook
   Dim Mailbox:    Mailbox = "test.vba.fanch55@free.fr"  ' Compte de Messagerie

    With CreateObject("Outlook.Application")
        ' Sélection du compte Mailbox dans outlook
        For Each Elem In .Session.Accounts
            If Elem = Mailbox Then Set Account = Elem: Exit For
        Next
        If Account Is Nothing Then MsgBox Mailbox & " non trouvé", vbCritical: Exit Sub
        Signature = GetSig(Signature) ' Récupération de la signature si elle existe
      
        Set Mail = .CreateItem(0)
        With Mail
            .Subject = "Commandes en retard d'expŽdition"
            .To = Destinataire
            .Cc = Destinataire
            .htmlbody = "<html><body><p>Bonjour,</p><br>" & _
                        "<p>Voici l'Žtat des commandes en retard d'expŽdition.</p>" & _
                        "<p>Bien cordialement,</p>" & _
                        "</body>" & Signature
            .Display
            Set Wedi = .GetInspector.wordeditor
                Wedi.Content.InsertParagraphAfter ' paragraphe en fin
                TCD.TableRange2.CopyPicture Appearance:=xlScreen, Format:=xlPicture
                Wedi.Paragraphs(Wedi.Paragraphs.Count).Range.Paste
                W = Wedi.Paragraphs(Wedi.Paragraphs.Count).Range.InlineShapes(1).Width
                Wedi.Paragraphs(Wedi.Paragraphs.Count).Range.InlineShapes(1).Width = W * 1.15
                Wedi.Content.InsertParagraphAfter
            Set Wedi = Nothing
                              
        End With
    End With

   Set Mail = Nothing
   Set TCD = Nothing
End Sub
Function GetSig(ByVal Signature As String) As String
Dim Fso As Object
Dim Txs As Object
Dim File As String
    Set Fso = CreateObject("Scripting.FileSystemObject")
        File = Environ("appdata") & "\Microsoft\Signatures\" & Signature & ".htm"
        Select Case True
            Case Signature = "":
            Case Not Fso.FileExists(File):
            Case Else
                Set Txs = Fso.GetFile(File).OpenAsTextStream(1, -2)
                    GetSig = Txs.ReadAll
                    Txs.Close
                Set Txs = Nothing
        End Select
    Set Fso = Nothing
End Function

Chez moi la signature n´apparait pas. Pourtant j’ai bien renseigné son nom dans le code...
Existe-t-elle vraiment dans Outlook ?
1707163197556.png
 

patricktoulon

XLDnaute Barbatruc
re
Bonjour
une autre proposition sans passer par l'inspector
tout en html
mais je pige pas le fait que le tableau soit après la signature
normalement la signature est à la fin
VB:
Option Explicit
Sub EnvoyerTCDparMail2()
    Dim TCD As Range, MailApp As Object, Mail As Object, Ws As Worksheet, Destinataire$, Fichier$, CorpsMail$, chemin$
    chemin = ThisWorkbook.Path & "\tcd.png"
    Set Ws = ActiveSheet
    Set TCD = Ws.PivotTables("tcd1").TableRange2
    If TCD Is Nothing Then
        MsgBox "Le tableau croisŽ dynamique 'tableau croisŽ 1' n'existe pas sur la feuille active.", vbExclamation
        Exit Sub
    End If
    Fichier = CopyOBJECTInImagePNG(TCD, chemin, True)    'on copie le tableau en png

    CorpsMail = "<html><body style=""font-family:calibri;font-size:11pt;""><p>Bonjour,</p><p>Voici l'état des commandes en retard d'expédition.</p><br>Cordialement.<br>"

    ' l'image du tableau
    CorpsMail = CorpsMail & "<img src=""tcd.png"" style=""width:" & Round(TCD.Width * 1.15) & "pt;height:" & Round(TCD.Height * 1.15) & "pt;""></img><br><br>"

    'la signature
    CorpsMail = CorpsMail & GetCodeSig("blablabla")    'adapter le nom de la signature

    'fermeture du body
    CorpsMail = CorpsMail & "</body></html>"


    Set MailApp = CreateObject("Outlook.Application")
    Set Mail = MailApp.CreateItem(0)

    Mail.Subject = "Commandes en retard d'expédition"
    Mail.htmlbody = CorpsMail
    Mail.To = Destinataire
    Mail.Cc = Destinataire
    Mail.attachments.Add Fichier


    Mail.Display
    'Mail.send
    Set Mail = Nothing
    Set MailApp = Nothing
    Set Ws = Nothing
    Set TCD = Nothing
    Kill Fichier
End Sub
Function GetCodeSig(ByVal Signature As String) As String
    Dim x%, lines$, i&, Fichier$: x = FreeFile
    Fichier = Environ("appdata") & "\Microsoft\Signatures\" & Signature & ".htm"
    If Dir(Fichier) = "" Then Exit Function
    Open Fichier For Input As #x: lines = Input$(LOF(x), #x): Close #x
    GetCodeSig = lines
End Function

'**********************************************************************************
' __        _____  ___   .  ___         _____  ___             ___
'|__|  /\     |   |   |  | |     | /      |   |   | |   | |   |   | |\  |
'|    /__\    |   |---   | |     |/\      |   |   | |   | |   |   | | \ |
'|   /    \   |   |   \  | |___  |  \     |   |___| |___| |__ |___| |  \|
'
'***********************************************************************************
'                           COLLECTION IMAGE ET SHAPES
'exporter un object en PNG(range,shapes et tout autre object present sur la feuille)
'version avec graphique 1.3(PNG)
'date version 03/05/2016
'mise  à jour:15/07/2018
'suppression de la gestion d'attente par l'api IsClipboardFormatAvailable
'remplacer par un multiple paste dans le chart tant que son pictures.count=0(Idée de @Job75)
'l'area du graph est visible ,solid et transparent  à 100%
'ce qui implique que la capture peut garder ses parties transparentes (argument <<Notransparency>>)
'**********************************************************************************
'ici en l'occurence on restera en fond blanc
Function CopyOBJECTInImagePNG(ObjecOrRange, _
                              Optional cheminx As String = "", _
                              Optional Notransparency As Boolean = False) As String
    Dim Graph As Object, CheminT$
    If cheminx = "" Then cheminx = ThisWorkbook.Path & "\imagetemp.png"
    CheminT = cheminx
    With CreateObject("htmlfile").parentwindow.clipboardData.clearData("Text"): End With    'on vide le clipboard entre chaque copie pour tester vraiment le available

    ObjecOrRange.CopyPicture Format:=IIf(Notransparency, xlBitmap, xlPicture)
    Set Graph = ObjecOrRange.Parent.ChartObjects.Add(0, 0, 0, 0).Chart
    ActiveSheet.Shapes(Graph.Parent.Name).Line.Visible = msoFalse
    With Graph.Parent
        .Width = ObjecOrRange.Width: .Height = ObjecOrRange.Height: .Left = ObjecOrRange.Width + 20:
        .Select
        Do: DoEvents
            .Chart.Paste
        Loop While .Chart.Pictures.Count = 0

        .Chart.ChartArea.Fill.Visible = msoTrue
        .Chart.ChartArea.Fill.Solid
        .Chart.ChartArea.Format.Fill.Transparency = 1

        .Chart.Export cheminx, "png"
    End With
    Graph.Parent.Delete
    CopyOBJECTInImagePNG = cheminx
End Function
le résultat
le font est en "calibri et size en 11pt
1707214440743.png

pour la signature
j'ai fait ma fonction perso (SANS FSO)
mais perso j'utilise mes fonctions perso qui me permette de transformer une plage en tableau html conforme à l'originale et avec les shapes images et tout autre objects convertis en PNG
(je n'utilise pas le dossier signature )

voilà le genre de trucs que l'on peut faire
1707216032873.png


alors pour placer une image dans un endroit precis ici en l'occurence le smiley
c'est un peu plus compliqué car outlook ne considère pas le style des element html
il faut passer en encodage MSO
sauf que tout le monde n'utilise pas outlook il faut donc encoder le html de la signature dans les deux formats
pour info voila le code de ma petite table en signature

HTML:
<TABLE style="FONT-SIZE: 11pt; MAX-WIDTH: 301pt; HEIGHT: 47pt; FONT-FAMILY: Calibri; WIDTH: 301pt; BORDER-COLLAPSE: collapse; TABLE-LAYOUT: fixed; POSITION: absolute; CLEAR: both; MAX-HEIGHT: 46pt">
<TBODY>
<TR height=17>
<TD id=A2:A4 style="WORD-WRAP: break-word; MAX-WIDTH: 60pt; BORDER-TOP: #92d050 2pt solid; HEIGHT: 46.5pt; BORDER-RIGHT: 0px; WIDTH: 60pt; BORDER-BOTTOM: #92d050 2pt solid; POSITION: relative; WORD-BREAK: break-all; TEXT-ALIGN: center; BORDER-LEFT: #92d050 2pt solid; MAX-HEIGHT: 46.5pt" vAlign=bottom rowSpan=3><FONT style="MARGIN: 0px 2px 0px 6px" face=Calibri><FONT size=+0></FONT></FONT>
<!--[if mso]>
<v:rect style="HEIGHT: 45.9pt; WIDTH: 45.24pt; POSITION: absolute; LEFT: 6pt; TOP: 2.75pt" xmlns:v="urn:schemas-microsoft-com:vml" fill="true" stroke="false" ><?xml:namespace prefix = "v" /><v:fill  type="frame" src="image1.png">
</v:fill></v:rect>
<![endif]-->
<!--[if !mso]><!-- -->
<IMG style="HEIGHT: 42.075pt; WIDTH: 46.545pt; POSITION: absolute; LEFT: 6pt; Z-INDEX: 1; TOP: 3.75pt" src="image1.png">
<!--<![endif]-->
</TD>
<TD id=B2:E2 style="WORD-WRAP: break-word; MAX-WIDTH: 240pt; BORDER-TOP: #92d050 2pt solid; HEIGHT: 15.75pt; BORDER-RIGHT: #92d050 2pt solid; WIDTH: 240pt; BORDER-BOTTOM: 0px; WORD-BREAK: break-all; TEXT-ALIGN: center; BORDER-LEFT: #000000 1px solid; MAX-HEIGHT: 15.75pt" vAlign=bottom colSpan=4><FONT style="MARGIN: 0px 2px 0px 6px" face=Calibri><FONT size=+0>Patrick Taratata</FONT></FONT></TD></TR>
<TR height=16>
<TD id=B3:E3 style="WORD-WRAP: break-word; MAX-WIDTH: 240pt; BORDER-TOP: #000000 1px solid; HEIGHT: 15pt; BORDER-RIGHT: #92d050 2pt solid; WIDTH: 240pt; BORDER-BOTTOM: #000000 1px solid; WORD-BREAK: break-all; TEXT-ALIGN: center; BORDER-LEFT: #000000 1px solid; MAX-HEIGHT: 15pt" vAlign=bottom colSpan=4><FONT style="MARGIN: 0px 2px 0px 6px" color=#0563c1>Patrick.Poleformat@youméméle.com</FONT></TD></TR>
<TR height=17>
<TD id=B4:E4 style="WORD-WRAP: break-word; MAX-WIDTH: 240pt; BORDER-TOP: #000000 1px solid; HEIGHT: 15.75pt; BORDER-RIGHT: #92d050 2pt solid; WIDTH: 240pt; BORDER-BOTTOM: #92d050 2pt solid; WORD-BREAK: break-all; TEXT-ALIGN: center; BORDER-LEFT: #000000 1px solid; MAX-HEIGHT: 15.75pt" vAlign=bottom colSpan=4><FONT style="MARGIN: 0px 2px 0px 6px" face=Calibri><FONT>Resposable du pôle formation </FONT></FONT></TD></TR></TBODY></TABLE></DIV>

et je me suis fait un outils pour ça
donc si ça vous intéresse faite moi signe
 

DR85

XLDnaute Junior
Bonjour,
merci pour votre contribution. Je vais tester.
Je n’ai pas de signature authentifiée, en fait c’est une signature fin de message. Mon nom et prénom avec le logo de l’entreprise.
Votre proposition de signature personnalisée m’intéresse, je vais étudier votre code.
Bonne journée
Damien
 

Rabeto

XLDnaute Occasionnel
Bonjour,

Je suis tomber sur ce fil et trouve le sujet très intéressant,
@patricktoulon J'ai essayé le code que vous avez proposé, et je me demande si c'est possible en modifiant le code de cibler les valeurs des cellules pour :

Destinataire : Cellule A1
En Copie : Cellule A2
Corp du mail : Cellule A3
 

Discussions similaires

Réponses
22
Affichages
2 K

Statistiques des forums

Discussions
313 224
Messages
2 096 338
Membres
106 572
dernier inscrit
JM04082023!