Copier range et coller dans mail

re

je soupconne cette ligne deja

Application.Transpose(Application.Transpose(dic_projects.Items))

comme c'est un TS meme si tu sépare avec une insertion de ligne le tableau comprend tout

je serait toi je travaillerais directement avec la base

ok je vais tenter depuis la base elle meme

mais le soucis c'est que je dois partir de mon onglet projet entier, lancer via une liste de triage dans un fichier temp (ca je sais faire) afin d'avoir les projets dans l'ordre de statut mais une fois cela fait :

je dois pouvoir virer les colonnes ne me servant pas..

Aller chercher dans les différents autres onglets toutes les informations requises par projet et les incorproerr dans ce meme temp pour ensuite etre mis dans un fichier et dans le mail..

Aussi comment procéder le plus simplement possible?

Voilà ce que j'obtiens brut de forge ... il y a des doublons ? des triplets ? sans rien modifier du fichier rapport, il est ce qu'il est et il reste ce qu'il est. Et pour le moment je n'ai rien touché à ton module de base.

capture d ecran 308

C’est effectivement ce que j´ai besoin de générer

Donc c'est simple ... rien d'autre ? des formats, des bordures ? il y aura des sesterces en euro ? où ? quelles colonnes ?

Pour le format, faut-il reprendre celui du fichier rapports ?

Fonction de ta réponse, je t'envoie le complément par rapport à ton code que je ne retoucherai pas, il fait le job.

Je ne suis plus devant mon ordi mais c’est la dernière colonne qui doit être en euro

Si on peut garder les bordures c’est mieux mais effectivement j’aimerais avoir la liste des projets actifs sous actif et ainsi de suite pour chaque catégorie

merci à vous en tout cas

quel code tu utilise Steelson que l'on parte sur la même base

voila j'ai tout passé en revu et j'avais omis plusieurs choses (c'est de ma faute)

10darkangel.zip (36.10 Ko)

donc voila le code du thisworkbook(oui j'ai fait un peu le ménage )

    Private Sub envoi_mail()
    Dim Ol As New Outlook.Application, Olmail As MailItem, RnGnego As Range, project_Active As Range, cel As Range, tabl, Tabl_nego
    chemin = ThisWorkbook.Path & "/"
    fichier = "rapport.xlsm"

    Application.ScreenUpdating = False
    Set wb = Workbooks.Open(chemin & fichier)
    Application.DisplayAlerts = False

    With wb.Sheets("Rapport")
        '**************************************************
        Set cel = .Columns("A").Find("Active", , xlValues)
        If Not cel Is Nothing Then
            Set project_Active = cel.MergeArea.Resize(, 9)
            count_active = project_Active.Rows.Count
            tabl = htmltable(project_Active)    'récupération du tableau en code html
        End If
        '**************************************************
        Set cel = .Columns("A").Find("Negociation", , xlValues)
        If Not cel Is Nothing Then
            count_nego = cel.MergeArea.Rows.Count
            Set RnGnego = cel.MergeArea.Resize(, 9)
            Tabl_nego = htmltable(RnGnego)    'récupération du tableau en code html
        End If
        '**************************************************
    End With
    wb.Close

    '********************************************outlook*****************************
    Set Ol = New Outlook.Application
    Set Olmail = Ol.CreateItem(olMailItem)
    With Olmail
        .To = "me@gmail.com"
        .CC = ""
        .Subject = "Suivi activité"
        '.Attachments.Add (chemin & fichier)
        Message = "Chers collègues, <br/><br/> Veuillez trouver ci-dessous l'état des stocks du jour, le " & Date & ". <br/><br/>" & _
                  "2)  Liste des projets actifs (" & count_active & " au total)<br>" & tabl & "<br/>" & _
                  "3) Lite des projets en négociation (" & count_nego & " au total)<br>" & Tabl_nego & _
                  "<br>Cordialement"
        .HTMLBody = Message
        '.send
        .display
    End With

End Sub

et maintenant mes fonction dans le module

Option Explicit
Function htmltable(plage As Range)
    Dim Doc As Object, TBODY, Table, TR, TD, Bord, Lig&, col&, cel As Range, Ta, Tal, Va, Vral
    Set Doc = CreateObject("htmlfile")
    Doc.Body.innerhtml = "<table><tbody></table></tbody>"
    Set Table = Doc.getelementsbytagname("TABLE")(0)
    With Table.Style
        .Bordercollapse = "collapse": .FontSize = "11pt": .fontfamily = "calibri"
    End With
    Set TBODY = Doc.getelementsbytagname("TBODY")(0)
    For Lig = 1 To plage.Rows.Count
        Set TR = Doc.createelement("TR")
        TBODY.appendchild (TR)
        For col = 1 To plage.Columns.Count
            Set cel = plage.Cells(Lig, col)
            If Doc.getelementbyid(cel.MergeArea.Address) Is Nothing Then
                Set TD = Doc.createelement("TD")
                TD.ID = cel.MergeArea.Address
                TD.rowspan = cel.MergeArea.Rows.Count: TD.colspan = cel.MergeArea.Columns.Count
                TD.Style.Width = Round(cel.MergeArea.Width) & "pt"
                TD.Style.Height = Round(cel.MergeArea.Height) & "pt"
                'TD.innerhtml = "<Font>" & cel.Value & "</font>"
                TD.innerhtml = "<Font>" & cel.Text & "</font>"
                TD.Style.Border = "1px solid  black"
                If cel(1).WrapText = True Then TD.Style.wordBreak = "break-all"                                  'applique le wraptext de la  cellule
                TD.Style.margin = "1pt"                                                                          'applique la marge de excel
                '******************************************************************************************************************************
                'option Bloquer ces lignes ci dessous  et vous avez votre tableau en noir et blanc(commentaire
                If Not IsNull(cel.Font.Color) And cel.Font.Color <> vbBlack Then TD.Style.Color = coul_XL_to_coul_HTMLX(cel.Cells(1).Font.Color)
                If Not IsNull(cel.Font.Name) Then TD.Style.fontfamily = cel.Font.Name                           'applique le font name de la cellule
                TD.Style.backgroundcolor = coul_XL_to_coul_HTMLX(cel.Interior.Color)                            'applique la couleur de fond de la cellule

                Bord = bordureTD(cel.MergeArea)                                                                 'appel fonction recupe le style de bordure en html
                TD.Style.BorderStyle = Bord(0)                                                                  'applique le border style
                TD.Style.borderwidth = Bord(1)                                                                  'applique le borderweight
                TD.Style.BorderColor = Bord(2)                                                                  'applique le bordercolor

                'alignement(commentaire)
                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"
                TD.Style.TextAlign = Tal
                TD.Style.verticalalign = Vral

                '******************************************************************************************************************************
                TR.appendchild (TD)
            End If
        Next
    Next
    htmltable = Table.outerhtml
End Function

Function bordureTD(cel)
'top right bottom left
    Dim tabl(3), BDTW, BDRW, BDBW, BDLW, BDTC, BDRC, BDBC, BDLC, bordurestyle, bordureweight, BorderColor
    With cel
        BDTW = IIf(.Borders(xlEdgeTop).LineStyle = xlNone, "1", .Borders(xlEdgeTop).Weight)
        BDRW = IIf(.Borders(xlEdgeRight).LineStyle = xlNone, "1", .Borders(xlEdgeRight).Weight)
        BDBW = IIf(.Borders(xlEdgeBottom).LineStyle = xlNone, "1", .Borders(xlEdgeBottom).Weight)
        BDLW = IIf(.Borders(xlEdgeLeft).LineStyle = xlNone, "1", .Borders(xlEdgeLeft).Weight)

        BDTC = IIf(.Borders(xlEdgeTop).LineStyle = xlNone, "#E6E6E6", coul_XL_to_coul_HTMLX(.Borders(xlEdgeTop).Color))
        BDRC = IIf(.Borders(xlEdgeRight).LineStyle = xlNone, "#E6E6E6", coul_XL_to_coul_HTMLX(.Borders(xlEdgeRight).Color))
        BDBC = IIf(.Borders(xlEdgeBottom).LineStyle = xlNone, "#E6E6E6", coul_XL_to_coul_HTMLX(.Borders(xlEdgeBottom).Color))
        BDLC = IIf(.Borders(xlEdgeLeft).LineStyle = xlNone, "#E6E6E6", coul_XL_to_coul_HTMLX(.Borders(xlEdgeLeft).Color))

        bordurestyle = .Borders(xlEdgeTop).LineStyle & " " & .Borders(xlEdgeRight).LineStyle & " " & .Borders(xlEdgeBottom).LineStyle & " " & .Borders(xlEdgeLeft).LineStyle
        bordurestyle = Replace(Replace(Replace(Replace(Replace(Replace(bordurestyle, -4118, "dotted"), "-4119", "double"), "-4115", "dashed"), "-4142", "solid"), "1", "solid"), "4", "dashed")

        bordureweight = BDTW & " " & BDRW & " " & BDBW & " " & BDLW
        BorderColor = BDTC & " " & BDRC & " " & BDBC & " " & BDLC
        bordureweight = Replace(Replace(Replace(Replace(Replace(bordureweight, "-4138", "2px "), 4, "3px "), 1, "1px "), 2, "2px "), " px", "")
    End With
    tabl(0) = bordurestyle
    tabl(1) = bordureweight
    tabl(2) = BorderColor
    bordureTD = tabl
End Function

Function coul_XL_to_coul_HTMLX(couleur)
    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

le résultat

demo7

Fabuleux Patrick,

d'un seul coup, plus de problème de #ref!, de listobjects, de name, de code en amont et de double transpose ...

quel code tu utilise Steelson que l'on parte sur la même base

on s'en fout ! on parle du résultat, mais pour ce qui est de ma prose, le code fait une petite dizaine de lignes

comme dit Montesquieu (Charles Louis de Secondat, baron de La Brède et de Montesquieu) :

"Le mieux est le mortel ennemi du bien"

(souvent mal retranscrit)

voila j'ai tout passé en revu et j'avais omis plusieurs choses (c'est de ma faute)

  
        Message = "Chers collègues, <br/><br/> Veuillez trouver ci-dessous l'état des stocks du jour, le " & Date & ". <br/><br/>" & _
                  "2)  Liste des projets actifs (" & count_active & " au total)<br>" & tabl & "<br/>" & _
                  "3) Lite des projets en négociation (" & count_nego & " au total)<br>" & Tabl_nego & _
                  "<br>Cordialement"
        .HTMLBody = Message

juste un conseil amical constructif, mets ceci pour avoir aussi ta propre signature outlook dans le mail

.HTMLBody = Message & .HTMLBody

L'objectif étant atteint, je ne vais pas me casser la tête et je vais m'occuper d'autres sujets ! Content juste d'avoir débloqué les choses.

re

bonjour Steelson si c'est important j'aimerais bien connaitre ton fabuleux code de 10 ligne qui gère les fusions

pour info voici un fichier test avec mes 3 versions: les 3 font le job et présentent des tableaux dignes de ce nom

version dom complète

version dom simple

version string

et pour la signature moi je ne m'en sert pas j’insère une image d’Entête (banderole en haut ou en bas ) dans mes message j'ai gardé ce principe car perso j'utilise plutôt CDO

Merci patrick, je vais désormais pouvoir voir comment le code fonctionne sachant que celui me donne le résultat escompté

grand merci à vous à votre assistance

est il toutefois possible de jouer sur la largeur des colonnes ? exemple la plus à droite donnant les budgets se met en retour à la ligne dès que ca dépasse le million..

@ DarkAngel ... même si Patrick n'est pas intéressé pour lui, comme tu utilises outlook

mets ceci pour avoir aussi ta propre signature outlook dans le mail

.HTMLBody = Message & .HTMLBody

@ Patrick,

si c'est important j'aimerais bien connaitre ton fabuleux code de 10 ligne qui gère les fusions

j'ai aussi une version en 2 lignes si tu veux critiquer (positivement bien sûr)

    Cells.Copy
' ...
    SendKeys "^v", True

ou en une petite dizaine, avec de belles grosses bordures que je n'aime pas pour bien mettre en valeur

edit : code amélioré voir ci-dessous

et samsuffit, expérience de 40 années industrielles où l'efficacité primait.

Voilà la dizaine de lignes de code ...

et avec nowrap comme demandé par DarkAngel

Merci patrick, ... les budgets se met en retour à la ligne dès que ca dépasse le million..

Function tableHTML(rng As Range)
Dim i%, j%, nbrow%, nbcol%
    tableHTML = "<table style=""white-space: nowrap; border: 1px solid black; border-collapse: collapse;"" >"
    For i = 1 To rng.Rows.Count
        tableHTML = tableHTML & "<tr>"
        For j = 1 To rng.Columns.Count
            If InStr(rng.Cells(i, j).MergeArea.Address, ":") > 0 Then
                nbrow = rng.Cells(i, j).MergeArea.Rows.Count: nbcol = rng.Cells(i, j).MergeArea.Columns.Count
                If rng.Cells(i, j).Address = Split(rng.Cells(i, j).MergeArea.Address, ":")(0) Then tableHTML = tableHTML & "<td " & IIf(nbcol > 1, "colspan=" & nbcol, "") & " " & IIf(nbrow > 1, "rowspan=" & nbrow, "") & " style=""border: 1px solid black; padding: 4px;"" >" & rng.Cells(i, j).Text & "</td>"
            Else
                tableHTML = tableHTML & "<td style=""border: 1px solid black; padding: 4px;"" >" & rng.Cells(i, j).Text & "</td>"
            End If
        Next
        tableHTML = tableHTML & "</tr>"
    Next
    tableHTML = tableHTML & "</table>"
End Function

bonsoir

@Steelson c'est ni plus ni moins que ce que je fait en string test d'existence est différent c'est tout les attributs css un peu différents

par contre les cellules (td) ne sont pas dimensionnées

@Darkangel mes 3 modèles reprennent la valeur en string et les largeurs sont sensées être identiques il est donc impossible que ta chaîne se mette en wrap dans les cellules html si elles ne le sont pas dans la feuille excel sauf modifs ultérieures

par contre les cellules (td) ne sont pas dimensionnées

et c'est tout à fait volontaire, le tableau s'adapte

à lire sur l'usage de pt et de px en css

https://www.w3.org/Style/Examples/007/units.fr.html

re

bonjour Steelson on est sur une table basique c'est pas vraiment nécessaire de convertir en le point en px

mais si tu y tiens dans ma fonction rangetohtml j'ai cette chose sans api

teste ça

Function P_ToPx()
With ActiveWindow.ActivePane
P_ToPx = (.PointsToScreenPixelsY(72) - .PointsToScreenPixelsY(0)) / 72
End With
end function

sub test()

msgbox [A1].width*P_ToPx

End sub

et oui car le coeff peut changer en fonction du dpi que tu utilise

par exemple moi je suis en DPI 120 sur mon grand écran donc 1 point =1.6666666667 pixel

tandis que sur mon ecran pc je suis en 96 donc (100) et donc 1 point = 1.333333333333333 pixel

enjoy :)

va faire un tour sur DVP ça date un peu c'est vrai 2013 je crois

aujourd’hui j'arrive a te rendre une table quasiment identique à la source excel suf quelque détails du genre dashdotted qui n'existe pas en html et que je transforme en dotted 1px de large en plus et quelque fontfamiliy qui ne sont pas pris en charge en html

Ce n'est pas nouveau, on a déjà rencontré ici des écarts entre excel par exemple et une sortie pdf, écarts qui varient d'un utilisateur à l'autre, d'un écran à l'autre. Je reste simple, je laisse le tableau se dimensionner seul. L'essentiel, ce sont les infos et le résultat, pas la forme.

Tu ne peux pas non plus nier les faits ...

il est donc impossible que ...

Maintenant, le client attend une solution, pas des cogitations.

oui justement une table non dimensionnée selon l'écran et l'application mail du destinataire la table sera transformée et peut être même illisible

après vous faite comme vous voulez

la c'est simple c'est lineaire mais dans d'autres cas il peut y avoir plusieurs lignes dans une cellules par le wrap ou des chr(10) et autres cochonneries

j'ai donné une solution universelle qui fonctionne avec une table simple ou plus complexe en terme de format

libre a vous de l'utiliser ou pas

perso un html je le travaillerais toujours en DOM c'est un minimum quand on veut faire du bon job

si tu préfère prendre un tournevis au lieu d'un ciseau a bois pour pour lamer un morceau de bois libre a toi mais ne prétend pas que c'est la meilleure solution

travailler en string est une des plus lourde charge en vba (je vais pas te l'apprendre) ça n'est d'ailleurs pas conseillé quand on peut s'en passer

quand a la cogitation tu devrais au contraire y penser ,c'est toujours mieux en développement vba ou autres d'applicatif

vous avez des outils servez vous en

Ce que je vois, c'est qu'un thème qui aurait dû être soldé en moins d'une page de fil de discussion est encore ouvert à la fin de la 3ème page !

Rechercher des sujets similaires à "copier range coller mail"