Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2013 Inclure un document dans le corps d'un courriel Outlook

Roseline

XLDnaute Occasionnel
Bonjour,
J'ai un fichier excel dans lequel j'inscrit des données pour les envoyer par courriel. Lorsque je clique sur le bouton retour, outlook s'ouvre et ajoute mon petit tableau dans le coprs du courriel Outlook en format jpg donc impossible à modifier car c'est une image. Tout fonctionne parfaitement bien jusque là sauf que j'aimerais pourvoir inclure ce petit tableau mais dans un format modifiable dans le corps du texte Outlook et non par un fichier joint.
Est-ce que vous auriez une solution pour moi svp.
J'ai joint mon fichier
Merci
 

Pièces jointes

  • Aide excel.xlsm
    47.2 KB · Affichages: 21

patricktoulon

XLDnaute Barbatruc
Bonjour @D.D. , @Roseline
ça vous dirais d'avoir le même tableau en excel et en html
j'ai greffé ma fonction tablehtml basique qui reproduit a l'identique le tableau sauf les bordures
la couleur du texte
la couleur du fond
le font size
le bold et ou italic
le font name
alignement vertical et ou horizontal du texte
les mêmes dimensions des cellules(accepte aussi les fusions et les reproduit)

il est pas beau mon tableau html



si plusieurs format dans une même cellule ou bordure voulues me demander le complément
et non ce n'ai pas une image !!!

voilà le code complet du module
VB:
Sub sendMail()
    Dim TempFilePath As String
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xHTMLBody As String
    Dim xRg As Range
    On Error Resume Next
    Set xRg = Range("A3:E10")
    If xRg Is Nothing Then Exit Sub
    With Application
        .Calculation = xlManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Set xOutApp = CreateObject("outlook.application")
    Set xOutMail = xOutApp.CreateItem(olMailItem)


    Call createJpg(ActiveSheet.Name, xRg.Address, "DashboardFile")
    TempFilePath = Environ$("Public") & "\"
    xHTMLBody = "<span LANG=EN>" _
              & "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
              & "Bonjour, <br><br>" _
              & "Ci-joint les retours <br> " _
              & "<br>"
    '    corps = "<body><p><font face=arial><FONT COLOR=MEDIUMBLUE>Liste des Avis mal renseignés: <BR><BR>"

    'Debug.Print CréateHTMLTABLE(xRg)    'juste pour voir un vrai code de table html  dans la console

    xHTMLBody = xHTMLBody & CréateHTMLTABLE(xRg) & "<br><br>"
    With xOutMail
        .Subject = "Demande de retour pour le mois...... - "
        .HTMLBody = xHTMLBody
        .Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
        .To = " "
        .Cc = " "
        .Display
    End With

    Kill "C:\Users\Public\Dashboardfile.jpg"
End Sub

Function CréateHTMLTABLE(plage As Range) As String
'Fonction range to table html ----> By patricktoulon
    Dim tbl, Addr$, I&, j&, cel As Range, TD, TR, Table, TA, Tal, VA, VraL, Texte
    With CreateObject("htmlfile")
        Set Table = .createelement("table"): .body.appendchild (Table)
        With Table.Style
            .bordercollapse = "collapse": .FontSize = "11pt": .fontfamily = "calibri"
            .Width = Round(plage.Width) + 1 & "pt"
        End With
        For I = 1 To plage.Rows.Count
            Set TR = .createelement("TR"): Table.appendchild (TR)
            For j = 1 To plage.Columns.Count
                Set cel = plage.Cells(I, j).MergeArea: Addr = cel.Address
                If .getelementbyid(Addr) Is Nothing Then
                    Set TD = .createelement("TD"): TD.ID = Addr: TD.colspan = cel.Columns.Count: TD.rowspan = cel.Rows.Count
                    Texte = IIf(cel.Font.Bold, "<B>" & cel.Text & "</B>", cel.Text)
                    Texte = IIf(cel.Font.Italic, "<EM>" & Texte & "</EM>", Texte)
                    Texte = IIf(cel.Font.Underline > 0, "<u>" & Texte & "</u>", Texte)



                    TD.innerhtml = Texte
                    'If cel(1).Font.Bold = True Then MsgBox "oui": TD.innerhtml "<B>" & TD.innertext & "</B>"
                    'If cel(1).Font.Italic Then TD.innerhtml "<i>" & TD.innerhtml & "</i>"

                    With TD.Style
                        .margin = "2pt": .Border = "0.5pt solid #000000"
                        .Width = Round(cel.Width) & "pt": .Height = Round(cel.Height) & "pt"
                        If Range(Addr).WrapText Then .WORDBREAK = "break-all"
                        If Val(cel.Font.Color) <> 0 Then .Color = coul_XL_to_coul_HTMLX(Val(cel.Font.Color))
                        If Val(cel.Interior.Color) <> 0 Then .backgroundcolor = coul_XL_to_coul_HTMLX(cel.Interior.Color)
                        If cel(1).Font.Name <> "calibri" Then .fontfamily = cel(1).Font.Name
                        If cel(1).Font.Size <> 11 Then .FontSize = cel(1).Font.Size & "pt"

                        'alignement
                        TA = cel.HorizontalAlignment: Tal = Switch(TA = xlLeft, "left", TA = xlCenter, "center", TA = xlRight, "right", TA = xlGeneral, "left", IsDate(cel.Value) And TA = xlGeneral, "right")
                        VA = cel.VerticalAlignment: VraL = Switch(VA = xlTop, "top", VA = xlCenter, "middle", VA = xlBottom, "bottom", VA = xlGeneral, "bottom")
                        If IsDate(cel.Value) And TA = xlGeneral Then Tal = "right"
                        .TextAlign = Tal
                        .verticalalign = VraL
                    End With
                    TR.appendchild (TD)
                End If
            Next
        Next
    End With
    CréateHTMLTABLE = Table.outerhtml
End Function

Function coul_XL_to_coul_HTMLX(couleur)
'fonction HTMLCOLOR ---> By Patricktoulon
    Dim str0 As String, strf As String
    str0 = Right("000000" & Hex(couleur), 6): strf = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)
    coul_XL_to_coul_HTMLX = "#" & strf & ""
End Function


Sub createJpg(SheetName As String, xRgAddrss As String, nameFile As String)
    Dim xRgPic As Range
    Dim xShape As Shape
    ThisWorkbook.Activate
    Worksheets(SheetName).Activate
    Set xRgPic = ThisWorkbook.Worksheets(SheetName).Range(xRgAddrss)
    xRgPic.CopyPicture
    With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
        .Activate
        For Each xShape In ActiveSheet.Shapes
            xShape.Line.Visible = msoFalse
        Next
        ' ajout du delay d'attente clipboard methode @job75
        Do While .Chart.Pictures.Count = 0
            .Chart.Paste
        Loop
        .Chart.Export Environ$("Public") & "\" & nameFile & ".jpg", "JPG"
    End With
    Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
    Set xRgPic = Nothing
End Sub
 
Dernière édition:

Roseline

XLDnaute Occasionnel
C'est vraiment super, je vais ajuster ma programmation en ce sens.....C'est vraiment wowowow, je suis très très contente. Merci énormément
 

thierry57

XLDnaute Nouveau
C'est vraiment super, je vais ajuster ma programmation en ce sens.....C'est vraiment wowowow, je suis très très contente. Merci énormément
Merci beaucoup !
J'ai remplacé Set xRg = Range("A3:E10")
par
Set xRg = Application.InputBox("Faites votre selection", Type:=8)
 

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…