Problème de Macro VBA pour envoyer un tableau avec sa mise en forme

**Marquisette65** · 06/02/2017, 14h47

Bonjour,

je vous écris car après de nombreuses recherches je n'arrive pas à créer la macro parfaite pour mon tableau.

Voilà mon problème: j'ai un classeur avec une quinzaine de feuilles, chaque feuille correspond à un client, sur chaque feuille le planning de l'année, où chaque mois est un tableau de 13 colonnes sur 43 lignes, jusque là tout va bien !
A chaque fin de mois je dois envoyer la sélection de cellules à chaque client. Jusqu'à présent je les imprimais mais j'aimerai mieux les envoyer par mail. Alors bien sûr je peux copier ma sélection dans un nouveau classeur et envoyer celui ci par mail mais, une petite macro serait quand même plus sympa !

alors en cherchant sur votre forum j'ai réussit à en faire une qui m’envoie la sélection que je lui demande, de la feuille active, sauf que ma mise en page de mon tableau initial est inexistante ! notamment les cellules fusionnées...
voici ma macro actuelle:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
 
Sub Envois_récap()
 
Dim iMsg As Object, iConf As Object, Flds As Object
Dim strHTML As String
Dim i As Byte, j As Byte
 
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields
 
strHTML = ""
strHTML = strHTML & "<HEAD>"
strHTML = strHTML & "<BODY>"
strHTML = strHTML & "Bonjour, <BR><BR>vous trouverez ci joint le récap du mois.<BR><BR>"
strHTML = strHTML & "<TABLE BORDER>"
 
For i = 1 To 43 
    strHTML = strHTML & "<TR halign='middle'nowrap>"
    For j = 1 To 13 'nombre de colonnes
        strHTML = strHTML & "<TD align='center'><FONT COLOR='black'SIZE=3>" _
        & Cells(i, j) & "</FONT></TD>"
    Next j
    strHTML = strHTML & "</TR>"
Next i
 
strHTML = strHTML & "</TABLE>"
strHTML = strHTML & "<BR><BR>Cordialement."
strHTML = strHTML & "</BODY>"
strHTML = strHTML & ""
 
With Flds
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.orange.fr"
    .Update
End With
 
With iMsg
    Set .Configuration = iConf
     .To = "moi@hotmail.fr"
    .From = "toi@hotmail.fr"
    .Subject = "test récap"
    .HTMLBody = strHTML
    .Send
End With
 
End Sub

je suis prête à modifier ou a changer totalement de macro...

Merci pour votre aide !

**Menhir** · 06/02/2017, 14h55

Le plus simple est de faire une copie "image" ta sélection que tu peux ajouter un mail.
https://msdn.microsoft.com/fr-fr/lib.../ff193594.aspx

N'ayant jamais traiter des mail par macro, je ne peux pas te dire comment faire un copier d'image dans un mail.

**Jean-Philippe André** · 07/02/2017, 14h18

Salut,

en plus de cette source de la

que tu as deja adaptée
https://excel.developpez.com/faq/?pa...geCellulesMail
je te propose celle qui suit avec SendRangeByMail

**Marquisette65** · 08/02/2017, 14h05

Merci Jean-Philippe !

J'ai suivit ton conseil, j'ai essayé d'adapter "SendRangeByMail" avec le reste mais en vain...

ma première macro est capable d'envoyer un mail, celle là de créer un fichier avec ce que je veux dedans, mais mes talents s'arrêtent là, je n'arrive pas à faire envoyer ce fichier dans le mail!!!!
alors après une soirée et une matinée d'essais, je capitule !
pourrais tu jeter un œil et me sauver s'il te plait??????

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
Sub SendRangeByMail()
 
Dim rngeSend As Range
Dim iMsg As Object, iConf As Object, Flds As Object
Dim strHTML As String
Dim i As Byte, j As Byte
 
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields
 
strHTML = ""
strHTML = strHTML & "<HEAD>"
strHTML = strHTML & "<BODY>"
strHTML = strHTML & "Bonjour, <BR><BR>Voici le récap du mois :<BR><BR>"
strHTML = strHTML & ""
strHTML = strHTML & "<BR><BR>Cordialement.<BR>"
strHTML = strHTML & "</BODY>"
strHTML = strHTML & ""
 
 
With Flds
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.orange.fr"
    .Update
End With
 
 
With Application
       On Error Resume Next
 
      ' Demande à l'utilisateur de sélectionner la plage de cellule
 
      Set rngeSend = .InputBox(Prompt:="Sélectionner les cellules à envoyer.", Type:=8, Default:=.Selection.Address)
 
      ' rngeSend Is Nothing lorsque l'utilisateur ne fait aucun choix
 
       If rngeSend Is Nothing Then Exit Sub
 
      On Error GoTo 0
 
      ' Exporte la plage vers un fichier de type HTML ceci afin de respecter la mise en page de la plage
 
      .ActiveWorkbook.PublishObjects.Add(4, "C:\essai\XLRange.htm", rngeSend.Parent.Name, rngeSend.Address, 0, "", "").Publish True
 
 
With iMsg
    Set .Configuration = iConf
    .To = "toi@hotmail.fr"
    .From = "moi@hotmail.fr"
    .Subject = "test récap"
    .HTMLBody = strHTML
    .Send
End With
 
 
      ' Le fichier HTML n'est plus nécessaire
      Kill "C:\essai\XLRange.htm"
 
   End With ' With Application
 
End Sub

et merci pour les "balises code" c'est vrai que c'est plus lisible !

**Jean-Philippe André** · 08/02/2017, 14h11

Si tu veux que le fichier soit en piece jointe, il faut passer par

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
With iMsg
'...
.Attachments.Add tonpathfichier
'...
End with

Invité · 09/02/2017, 13h42

Triskell

kenavo

Invité · 09/02/2017, 13h10

tu copie ça dans un module quelconque et tu l'oublis!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
Function range_to_html_DOM3(PLAGE, Optional en_couleur As Boolean = False) As String 
    Dim TD, TR, Doc, Table, cel As Range, V, TA, VRL, TAL, i As Long, lig As Long, col As Long, mesTD, B As Boolean
Dim rangeleft As Range, rangeTOP As Range, rangeBOTTOM As Range, RL, R
    Set Doc = CreateObject("htmlfile")
    With Doc
        .write "<Table id=""tabl"" cellspacing=15 cellpadding=0 style=""table-layout: fixed;border-collapse:collapse;""></table>"
        Set Table = .getelementbyid("tabl"): Table.Style.Width = Round(PLAGE.Width * 1.75) & "px":
        For lig = PLAGE.Row To PLAGE.Row + (PLAGE.Rows.Count - 1)
            Set TR = .createElement("TR")
            Table.appendchild (TR)
            For col = PLAGE.Column To PLAGE.Column + (PLAGE.Columns.Count - 1)
                Set cel = Cells(lig, col).MergeArea
                If .getelementbyid(cel.Address) Is Nothing Then
                    Set TD = .createElement("TD")
                    TD.ID = cel.Address: TD.rowspan = cel.Rows.Count: TD.colspan = cel.Columns.Count: TD.Style.Border = "0.1pt solid #CED8F6"
                    TD.Style.Width = Round(cel.Width * 1.7) & "px": TD.Style.Height = Round(cel.Height * 1.6666666) & "px"
                    If cel.WrapText = True Then TD.Style.WordWrap = "break-word"
                    V = cel.VerticalAlignment: VRL = Switch(V = xlTop, "top", V = xlBottom, "bottom", V = xlCenter, "middle"): TD.Style.verticalAlign = VRL
                    TA = cel.HorizontalAlignment: TAL = Switch(TA = xlLeft, "left", TA = xlCenter, "center", TA = xlRight, "right"): If Not IsNull(TAL) Then TD.Style.textAlign = TAL
                    If en_couleur Then
                        If cel.Cells(1).Value <> "" Then TD.innerhtml = text_formaté(cel.Cells(1))
                        TD.Style.bordertop = borderstyle(cel.Borders(xlEdgeTop))
                        TD.Style.borderleft = borderstyle(cel.Borders(xlEdgeLeft))
                        TD.Style.borderbottom = borderstyle(cel.Borders(xlEdgeBottom))
                        TD.Style.borderright = borderstyle(cel.Borders(xlEdgeRight))
                        TD.Style.backgroundcolor = coul_XL_to_coul_HTMLX(cel.Interior.Color)
                    Else
                        TD.innerhtml = IIf(cel.Cells(1).Value <> "", cel.Cells(1).Value, "")
                    End If
                    'corection des marginright et marginleft du texte dans les cellules HTML
                    If TD.Children.Length > 0 Then
                        For i = 1 To TD.Children.Length - 1
                        TD.Children(i).Style.margin = "0.5pt"
                        Next
                        TD.LastChild.Style.MarginRight = "3px": TD.FirstChild.Style.MarginLeft = "3px"
                    Else
                        If TD.innertext <> "" Then TD.FirstChild.Style.MarginRight = "3px"
                    End If
                End If
                TR.appendchild (TD)
            Next
        Next
 
 
        'correction des bordure gauche et droite en cas de fusion sur plusieurs lignes
        Set mesTD = .getelementsbytagname("TD")
        For i = 0 To mesTD.Length - 1
            'gauche et droite en cas de fusion sur plusieurs lignes
            If Range(mesTD(i).ID).Rows.Count > 1 And Range(mesTD(i).ID).Column > PLAGE.Column Then
                B = True
                Set rangeleft = Range(mesTD(i).ID).Offset(0, -1).Resize(Range(mesTD(i).ID).Rows.Count, 1)
                For RL = 2 To rangeleft.Cells.Count
                    If rangeleft.Cells(RL).Borders(xlEdgeRight).LineStyle <> rangeleft.Cells(RL - 1).Borders(xlEdgeRight).LineStyle Then B = False
                Next
                If B = True Then
                    For Each cel In rangeleft.Cells
                        .getelementbyid(cel.MergeArea.Address).Style.borderright = 0
                    Next
                Else
                    mesTD(i).Style.borderleft = 0
                End If
            End If
            'top et basse en cas de fusion sur plusieurs colonne
            If Range(mesTD(i).ID).Columns.Count > 1 And Range(mesTD(i).ID).Column >= PLAGE.Column Then
                B = True
                Set rangeBOTTOM = Range(mesTD(i).ID).Offset(1, 0).Resize(1, Range(mesTD(i).ID).Columns.Count)
                Set rangeTOP = Range(mesTD(i).ID).Offset(-1, 0).Resize(1, Range(mesTD(i).ID).Columns.Count)
                For RL = 2 To rangeBOTTOM.Cells.Count
                    If rangeBOTTOM.Cells(RL).Borders(xlEdgeTop).LineStyle <> rangeBOTTOM.Cells(RL - 1).Borders(xlEdgeTop).LineStyle Then B = False
                Next
                If B = True Then
                    For Each cel In rangeleft.Cells: .getelementbyid(cel.MergeArea.Address).Style.bordertop = 0: Next
                Else
                    mesTD(i).Style.borderbottom = 0
                End If
 
                For RL = 2 To rangeTOP.Cells.Count
                    If rangeTOP.Cells(RL).Borders(xlEdgeBottom).LineStyle <> rangeTOP.Cells(RL - 1).Borders(xlEdgeBottom).LineStyle Then B = False
                Next
                If B = True Then
                    For Each cel In rangeleft.Cells: .getelementbyid(cel.MergeArea.Address).Style.borderbottom = 0: Next
                Else
                    mesTD(i).Style.bordertop = 0
                End If
            End If
        Next
        For i = 0 To mesTD.Length - 1
            If mesTD(i).colspan = 1 And mesTD(i).rowspan = 1 And Range(mesTD(i).ID).Row > PLAGE.Row Then
                Set R = Range(mesTD(i).ID).Offset(-1, 0).MergeArea
 
                If .getelementbyid(R.Address).Style.borderbottom = mesTD(i).Style.bordertop Then mesTD(i).Style.bordertop = 0
            End If
        Next
        For i = 0 To mesTD.Length - 1
            If mesTD(i).colspan = 1 And mesTD(i).rowspan = 1 And Range(mesTD(i).ID).Column > PLAGE.Column Then
                Set R = Range(mesTD(i).ID).Offset(0, -1).MergeArea
                Debug.Print R.Address
                If .getelementbyid(R.Address).Style.borderright = mesTD(i).Style.borderleft Then mesTD(i).Style.borderleft = 0
            End If
        Next
        'Debug.Print .body.innerhtml
        range_to_html_DOM3 = .body.innerhtml
    End With
 
End Function
Function text_formaté(cel)
    Dim F, Doc, L, formt, mot, forma, font, i As Long
    Set Doc = CreateObject("htmlfile")
    Doc.write "<br><div id=""mot""></div>"
    F = ""
    With Doc
        Set mot = .getelementbyid("mot")
        If IsDate(cel.Value) Then
            forma = cel.NumberFormat
            Set font = .createElement("FONT")
            font.innerhtml = IIf(cel.font.Italic, "<em>" & Format(cel.Value, forma) & "</em>", Format(cel.Value, forma))
            font.innerhtml = IIf(cel.font.Bold, "<strong>" & font.innerhtml & "</strong>", Format(cel.Value, forma))
            font.Color = coul_XL_to_coul_HTMLX(cel.font.Color): font.face = cel.font.Name: font.Size = Round(cel.font.Size / 3) & "px "
            text_formaté = font.outerhtml: Exit Function
        End If
        If IsNumeric(cel.Value) Then
            Set font = .createElement("FONT")
            font.innerhtml = IIf(cel.font.Italic, "<em>" & cel.Value & "</em>", cel.Value)
            font.innerhtml = IIf(cel.font.Bold, "<strong>" & font.innerhtml & "</strong>", cel.Value)
            font.Color = coul_XL_to_coul_HTMLX(cel.font.Color): font.face = cel.font.Name: font.Size = Round(cel.font.Size / 3) & "px "
            text_formaté = font.outerhtml: If cel.NumberFormat <> "@" Then Exit Function
        End If
        For i = 1 To Len(cel.Value)
            L = CStr(cel.Characters(Start:=i, Length:=1).Text)
            formt = "size=" & Round(cel.Characters(Start:=i, Length:=1).font.Size / 3) & "pt " & "face=""" & cel.Characters(Start:=i, Length:=1).font.Name & Chr(34) & " "
            formt = formt & "color=""" & coul_XL_to_coul_HTMLX(cel.Characters(Start:=i, Length:=1).font.Color) & Chr(34) & ">"
            If F <> formt Then
                Set font = .createElement("FONT"): F = formt
                font.Color = coul_XL_to_coul_HTMLX(cel.Characters(Start:=i, Length:=1).font.Color)
                font.face = cel.Characters(Start:=i, Length:=1).font.Name
                font.Size = Round(cel.Characters(Start:=i, Length:=1).font.Size / 3) & "px "
            End If
            If cel.Characters(Start:=i, Length:=1).font.Italic = True Then L = "<em>" & L & "</em>"
            If cel.Characters(Start:=i, Length:=1).font.Bold = True Then L = "<strong>" & L & "</strong>"
            font.innerhtml = font.innerhtml & L
            mot.appendchild (font)
        Next
        text_formaté = Replace(mot.innerhtml, "</STRONG><STRONG>", "")
        'Debug.Print Replace(mot.innerhtml, "</STRONG><STRONG>", "")
    End With
    Set Doc = Nothing
End Function
Function coul_XL_to_coul_HTMLX(couleur)
    Dim str0 As String, str As String
    'If couleur = 16777215 Then couleur = vbWhite
    str0 = Right("000000" & Hex(couleur), 6)
    str = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)
    coul_XL_to_coul_HTMLX = "#" & str & ""
End Function
Function borderstyle(Cote)
    Dim borderweight, bstyle As String, bcolor As String
    If Cote.LineStyle = xlNone Then borderstyle = "0.1pt solid #CED8F6": GoTo fin
    borderweight = Switch(Cote.Weight = 1, 1, Cote.Weight = 2, 1, Cote.Weight = -4138, 2, Cote.Weight = 4, 3) & "px  "
    bstyle = IIf(Cote.LineStyle <> 1, "dashed", "solid")    'xlDouble
    If Cote.LineStyle = xlDash And Cote.Weight = xlThick Then borderweight = 3 & "px  "   ' xldash et epaisseur xlthick   'Tiret en pointillet
    If Cote.LineStyle = xlDash And Cote.Weight = xlThin Then borderweight = 2 & "px  ":: bstyle = "dotted"     'point  en pointillet
    If Cote.LineStyle = xlDashDotDot Then bstyle = " dashed": borderweight = 3 & "px  "  'xlDashDotDot
    If Cote.LineStyle = xlDouble Then bstyle = " double": borderweight = 3 & "px  "
    bcolor = coul_XL_to_coul_HTMLX(Cote.Color)
    borderstyle = borderweight & bstyle & "  " & bcolor
fin:
End Function

ensuite tu ne t'intersessions qu'a ça et tu poste autant e question que tu as besoin!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

code = range_to_html_DOM3(PLAGE, True)

c'est jouable non?

Invité · 08/02/2017, 14h15

Bonjour,

https://www.developpez.net/forums/d1...t/#post7968025

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
Sub test()
TableHtml = RangetoHTML(ActiveSheet.UsedRange)
MailEnvoi "smtp.googlemail.com", True, "My.Mail@gmail.com", "Pasw", 465, 10, "My.Mail@gmail.com", "Vous.Mail@gmail.com", "Copy@gmail.com", "Suivi des modifications.", TableHtml, ""
End Sub
Function RangetoHTML(rng As Range) As String
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
    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
    'Delete the htm file we used in this function
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
 
 
Public Sub MailEnvoi(Serveur, Identify, User, PassWord, Port, Delay, Expediteur, Dest, DestEnCopy, Objet, Body, Pj)
' sub pour envoyer les mails
Dim msg
Dim Conf
Dim Config
Dim ess
Dim splitPj
Dim IsplitPj
Set msg = CreateObject("CDO.Message") 'pour la configuration du message
Set Conf = CreateObject("CDO.Configuration") '  pour la configuration de l'envoi
Dim strHTML
 
Set Config = Conf.Fields
 
' Configuration des parametres d'envoi
'(SMTP - Identification - SSL - Password - Nom Utilisateur - Adresse messagerie)
With Config
If Identify = True Then
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = User
    .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = PassWord
End If
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = Port
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = Serveur
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = Delay
    .Update
 
End With
 
 
'Configuration du message
'If E_mail.Sign.Value = Checked Then Convert ServeurFrm.SignTXT, ServeurFrm.Text1
 
With msg
    Set .Configuration = Conf
    .To = Dest
  .cc = DestEnCopy
    .FROM = Expediteur
    .Subject = Objet
'
 
    .HTMLBody = Body '"<p align=""center""><font face=""Verdana"" size=""1"" color=""#9224FF""><b><br><font face=""Comic Sans MS"" size=""5"" color=""#FF0000""></b><i>" & body & "</i></font> " 'E_mail.ZThtml.Text
            If Pj <> "" Then
        splitPj = Split(Pj & ";", ";")
 
        For IsplitPj = 0 To UBound(splitPj)
            If Trim("" & splitPj(IsplitPj)) <> "" Then
                .AddAttachment Trim("" & splitPj(IsplitPj))
            End If
        Next
 
    End If
    .Send 'envoi du message
 
End With
' reinitialisation des variables
Set msg = Nothing
Set Conf = Nothing
Set Config = Nothing
 
End Sub

**Marquisette65** · 08/02/2017, 17h23

Merci Jean-Philippe,

visiblement ça fonctionne mais ça m'envoit un fichier.bin, qu'est ce que c'est que cette bête ?????

Merci Dysorthographie,

mais mes connaissances sont trop maigres, je n'arrive pas à l'adapter pour qu'il fonctionne...

Invité · 08/02/2017, 17h43

Envoyé par Marquisette65

Merci Dysorthographie,

mais mes connaissances sont trop maigres, je n'arrive pas à l'adapter pour qu'il fonctionne...

Difficile a dire vue que j'ai mis tout le code utile dans le message et que dans la sub test tu n'a juste qu'a compléter le manque UsedRange par la plage de cellules que tu veux envoyer ainsi que les informations pour l'envoi de mails MailEnvoi(seveur,login,destinataire,etc...)

**patricktoulon** · 08/02/2017, 23h16

bonsoir a tous

je suis étonné que personne ne te l'ai encore dit!!!
aucune des fonctions ou procédures natives de vba a excel y compris sendmail ne te rendra la mise en formea 100% je dis bien aucune sauf si tu n'a pas de fusion et que les bordures et tout propriétés de format ne dépasse pas ce que peut reproduire le html et dieu sais qu'il y a beaucoup de différence

tu trouvera dans les contributions ma contrib grille excel to html qui a été pendant un bon moment celle que je me suis servi mais quand même limité en terme de format et pourtant déjà bien travaillé

alors récemment j'ai revu la copie afin de rendre la table html obtenue au plus proche de la table exel (il y a quand même des toute petite choses impossible mais visuellement on est a 98% identique

voila donc ma version 2017 de la fonction
il y a donc

la fonction de convertion (exc el/html)
la fonction convertion de code couleur excel /html
la fonction conversion borderstyle pour les bordures
la fonction textformaté (qui reprends l'idée de ma fonction "byspan" de la contribution ) mais qui est plus propre au rendu final en terme de double balise
et donc dans cette version enfin le wraptext est pris en compte

bref il y en aurait beaucoup a dire mais je préfère le faire dans la mise a jour de ma contribution
en attendant voila le code module au complet suivi de la démo animée
colle ca dans un module standard et adapte ta plage dans la sub """TESTENDOM3"""

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
Sub TESTENDOM3()
   Dim PLAGE As Range, code As String, IE As Object
    Set PLAGE = Sheets(1).Range("A4:C" & Cells(Rows.Count, 1).End(xlUp).Row) 'adqapter la plage ici
    code = range_to_html_DOM3(PLAGE, True)
    Set IE = CreateObject("internetexplorer.application")
    With IE
        .Visible = True: .Left = 100: .Navigate "about:blank"    ' la position de la fenetre ie est en dehors du chanps de l'ecran (pas la peine dela voir ca n'est pas necessaire
        .Document.write code
    End With
End Sub
Function range_to_html_DOM3(PLAGE, Optional en_couleur As Boolean = False) As String
 
    Dim TD, TR, Doc, Table, cel As Range, V, TA, VRL, TAL, i As Long, lig As Long, col As Long, mesTD, B As Boolean
Dim rangeleft As Range, rangeTOP As Range, rangeBOTTOM As Range, RL, R
    Set Doc = CreateObject("htmlfile")
    With Doc
        .write "<Table id=""tabl"" cellspacing=15 cellpadding=0 style=""table-layout: fixed;border-collapse:collapse;""></table>"
        Set Table = .getelementbyid("tabl"): Table.Style.Width = Round(PLAGE.Width * 1.75) & "px":
        For lig = PLAGE.Row To PLAGE.Row + (PLAGE.Rows.Count - 1)
            Set TR = .createElement("TR")
            Table.appendchild (TR)
            For col = PLAGE.Column To PLAGE.Column + (PLAGE.Columns.Count - 1)
                Set cel = Cells(lig, col).MergeArea
                If .getelementbyid(cel.Address) Is Nothing Then
                    Set TD = .createElement("TD")
                    TD.ID = cel.Address: TD.rowspan = cel.Rows.Count: TD.colspan = cel.Columns.Count: TD.Style.Border = "0.1pt solid #CED8F6"
                    TD.Style.Width = Round(cel.Width * 1.7) & "px": TD.Style.Height = Round(cel.Height * 1.6666666) & "px"
                    If cel.WrapText = True Then TD.Style.WordWrap = "break-word"
                    V = cel.VerticalAlignment: VRL = Switch(V = xlTop, "top", V = xlBottom, "bottom", V = xlCenter, "middle"): TD.Style.verticalAlign = VRL
                    TA = cel.HorizontalAlignment: TAL = Switch(TA = xlLeft, "left", TA = xlCenter, "center", TA = xlRight, "right"): If Not IsNull(TAL) Then TD.Style.textAlign = TAL
                    If en_couleur Then
                        If cel.Cells(1).Value <> "" Then TD.innerhtml = text_formaté(cel.Cells(1))
                        TD.Style.bordertop = borderstyle(cel.Borders(xlEdgeTop))
                        TD.Style.borderleft = borderstyle(cel.Borders(xlEdgeLeft))
                        TD.Style.borderbottom = borderstyle(cel.Borders(xlEdgeBottom))
                        TD.Style.borderright = borderstyle(cel.Borders(xlEdgeRight))
                        TD.Style.backgroundcolor = coul_XL_to_coul_HTMLX(cel.Interior.Color)
                    Else
                        TD.innerhtml = IIf(cel.Cells(1).Value <> "", cel.Cells(1).Value, "")
                    End If
                    'corection des marginright et marginleft du texte dans les cellules HTML
                    If TD.Children.Length > 0 Then
                        For i = 1 To TD.Children.Length - 1
                        TD.Children(i).Style.margin = "0.5pt"
                        Next
                        TD.LastChild.Style.MarginRight = "3px": TD.FirstChild.Style.MarginLeft = "3px"
                    Else
                        If TD.innertext <> "" Then TD.FirstChild.Style.MarginRight = "3px"
                    End If
                End If
                TR.appendchild (TD)
            Next
        Next
 
 
        'correction des bordure gauche et droite en cas de fusion sur plusieurs lignes
        Set mesTD = .getelementsbytagname("TD")
        For i = 0 To mesTD.Length - 1
            'gauche et droite en cas de fusion sur plusieurs lignes
            If Range(mesTD(i).ID).Rows.Count > 1 And Range(mesTD(i).ID).Column > PLAGE.Column Then
                B = True
                Set rangeleft = Range(mesTD(i).ID).Offset(0, -1).Resize(Range(mesTD(i).ID).Rows.Count, 1)
                For RL = 2 To rangeleft.Cells.Count
                    If rangeleft.Cells(RL).Borders(xlEdgeRight).LineStyle <> rangeleft.Cells(RL - 1).Borders(xlEdgeRight).LineStyle Then B = False
                Next
                If B = True Then
                    For Each cel In rangeleft.Cells
                        .getelementbyid(cel.MergeArea.Address).Style.borderright = 0
                    Next
                Else
                    mesTD(i).Style.borderleft = 0
                End If
            End If
            'top et basse en cas de fusion sur plusieurs colonne
            If Range(mesTD(i).ID).Columns.Count > 1 And Range(mesTD(i).ID).Column >= PLAGE.Column Then
                B = True
                Set rangeBOTTOM = Range(mesTD(i).ID).Offset(1, 0).Resize(1, Range(mesTD(i).ID).Columns.Count)
                Set rangeTOP = Range(mesTD(i).ID).Offset(-1, 0).Resize(1, Range(mesTD(i).ID).Columns.Count)
                For RL = 2 To rangeBOTTOM.Cells.Count
                    If rangeBOTTOM.Cells(RL).Borders(xlEdgeTop).LineStyle <> rangeBOTTOM.Cells(RL - 1).Borders(xlEdgeTop).LineStyle Then B = False
                Next
                If B = True Then
                    For Each cel In rangeleft.Cells: .getelementbyid(cel.MergeArea.Address).Style.bordertop = 0: Next
                Else
                    mesTD(i).Style.borderbottom = 0
                End If
 
                For RL = 2 To rangeTOP.Cells.Count
                    If rangeTOP.Cells(RL).Borders(xlEdgeBottom).LineStyle <> rangeTOP.Cells(RL - 1).Borders(xlEdgeBottom).LineStyle Then B = False
                Next
                If B = True Then
                    For Each cel In rangeleft.Cells: .getelementbyid(cel.MergeArea.Address).Style.borderbottom = 0: Next
                Else
                    mesTD(i).Style.bordertop = 0
                End If
            End If
        Next
        For i = 0 To mesTD.Length - 1
            If mesTD(i).colspan = 1 And mesTD(i).rowspan = 1 And Range(mesTD(i).ID).Row > PLAGE.Row Then
                Set R = Range(mesTD(i).ID).Offset(-1, 0).MergeArea
 
                If .getelementbyid(R.Address).Style.borderbottom = mesTD(i).Style.bordertop Then mesTD(i).Style.bordertop = 0
            End If
        Next
        For i = 0 To mesTD.Length - 1
            If mesTD(i).colspan = 1 And mesTD(i).rowspan = 1 And Range(mesTD(i).ID).Column > PLAGE.Column Then
                Set R = Range(mesTD(i).ID).Offset(0, -1).MergeArea
                Debug.Print R.Address
                If .getelementbyid(R.Address).Style.borderright = mesTD(i).Style.borderleft Then mesTD(i).Style.borderleft = 0
            End If
        Next
        'Debug.Print .body.innerhtml
        range_to_html_DOM3 = .body.innerhtml
    End With
 
End Function
Function text_formaté(cel)
    Dim F, Doc, L, formt, mot, forma, font, i As Long
    Set Doc = CreateObject("htmlfile")
    Doc.write "<br><div id=""mot""></div>"
    F = ""
    With Doc
        Set mot = .getelementbyid("mot")
        If IsDate(cel.Value) Then
            forma = cel.NumberFormat
            Set font = .createElement("FONT")
            font.innerhtml = IIf(cel.font.Italic, "<em>" & Format(cel.Value, forma) & "</em>", Format(cel.Value, forma))
            font.innerhtml = IIf(cel.font.Bold, "<strong>" & font.innerhtml & "</strong>", Format(cel.Value, forma))
            font.Color = coul_XL_to_coul_HTMLX(cel.font.Color): font.face = cel.font.Name: font.Size = Round(cel.font.Size / 3) & "px "
            text_formaté = font.outerhtml: Exit Function
        End If
        If IsNumeric(cel.Value) Then
            Set font = .createElement("FONT")
            font.innerhtml = IIf(cel.font.Italic, "<em>" & cel.Value & "</em>", cel.Value)
            font.innerhtml = IIf(cel.font.Bold, "<strong>" & font.innerhtml & "</strong>", cel.Value)
            font.Color = coul_XL_to_coul_HTMLX(cel.font.Color): font.face = cel.font.Name: font.Size = Round(cel.font.Size / 3) & "px "
            text_formaté = font.outerhtml: If cel.NumberFormat <> "@" Then Exit Function
        End If
        For i = 1 To Len(cel.Value)
            L = CStr(cel.Characters(Start:=i, Length:=1).Text)
            formt = "size=" & Round(cel.Characters(Start:=i, Length:=1).font.Size / 3) & "pt " & "face=""" & cel.Characters(Start:=i, Length:=1).font.Name & Chr(34) & " "
            formt = formt & "color=""" & coul_XL_to_coul_HTMLX(cel.Characters(Start:=i, Length:=1).font.Color) & Chr(34) & ">"
            If F <> formt Then
                Set font = .createElement("FONT"): F = formt
                font.Color = coul_XL_to_coul_HTMLX(cel.Characters(Start:=i, Length:=1).font.Color)
                font.face = cel.Characters(Start:=i, Length:=1).font.Name
                font.Size = Round(cel.Characters(Start:=i, Length:=1).font.Size / 3) & "px "
            End If
            If cel.Characters(Start:=i, Length:=1).font.Italic = True Then L = "<em>" & L & "</em>"
            If cel.Characters(Start:=i, Length:=1).font.Bold = True Then L = "<strong>" & L & "</strong>"
            font.innerhtml = font.innerhtml & L
            mot.appendchild (font)
        Next
        text_formaté = Replace(mot.innerhtml, "</STRONG><STRONG>", "")
        'Debug.Print Replace(mot.innerhtml, "</STRONG><STRONG>", "")
    End With
    Set Doc = Nothing
End Function
Function coul_XL_to_coul_HTMLX(couleur)
    Dim str0 As String, str As String
    'If couleur = 16777215 Then couleur = vbWhite
    str0 = Right("000000" & Hex(couleur), 6)
    str = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)
    coul_XL_to_coul_HTMLX = "#" & str & ""
End Function
Function borderstyle(Cote)
    Dim borderweight, bstyle As String, bcolor As String
    If Cote.LineStyle = xlNone Then borderstyle = "0.1pt solid #CED8F6": GoTo fin
    borderweight = Switch(Cote.Weight = 1, 1, Cote.Weight = 2, 1, Cote.Weight = -4138, 2, Cote.Weight = 4, 3) & "px  "
    bstyle = IIf(Cote.LineStyle <> 1, "dashed", "solid")    'xlDouble
    If Cote.LineStyle = xlDash And Cote.Weight = xlThick Then borderweight = 3 & "px  "   ' xldash et epaisseur xlthick   'Tiret en pointillet
    If Cote.LineStyle = xlDash And Cote.Weight = xlThin Then borderweight = 2 & "px  ":: bstyle = "dotted"     'point  en pointillet
    If Cote.LineStyle = xlDashDotDot Then bstyle = " dashed": borderweight = 3 & "px  "  'xlDashDotDot
    If Cote.LineStyle = xlDouble Then bstyle = " double": borderweight = 3 & "px  "
    bcolor = coul_XL_to_coul_HTMLX(Cote.Color)
    borderstyle = borderweight & bstyle & "  " & bcolor
fin:
End Function

maintenant la démo

Nom : demo2.gif
Affichages : 1199
Taille : 943,9 Ko

**Menhir** · 09/02/2017, 09h02

Envoyé par patricktoulon

aucune des fonctions ou procédures natives de vba a excel y compris sendmail ne te rendra la mise en formea 100%

Bin si, celle que j'ai indiqué : un Range.CopyPicture, c'est-à-dire faire une copie "image" de la zone.

Là, tu es sûr que ton correspondant verra exactement ce que tu souhaites. Pas de soucis de polices de caractères, de version d'Excel ou de fichier lié. C'est du bronze.
Il y a aussi la solution de faire un PDF mais c'est moins sûr, en particulier à cause de la découpe en pages et parce que Excel est loin d'être WYSIWYG.

Le revers de la médaille, c'est que les données sont difficilement récupérables pour un usage postérieur (mais dans certains cas, ça peut être un avantage).

Invité · 09/02/2017, 14h47

y en aurait pas un de vous qui habite dans le sud ouest????

si Patrick si colle , après tous Toulon c'est pas si loin en bagnole!

nous essayons de t'aider en fonction des difficultés que nous percevons chez toi! donc nous te proposons plusieurs pistes!

le générateur d'état de Manhir qui te permet de générer un code en fonction des action que tu exécute avec le clavier ou la souris! en d'autre terme tu éclanche le générateur de macro, tu te position sur l'onglet que tu veux puis enregistre sous PDF!

tu as ma méthode qui consiste à publier ton fichier au format HTML, soit tu utilise le code que j'ai fourni en l'état et tu modifies les information se trouvant dans la sub test ou tu utilises le générateur de macro mais tu choisis publier dans le menu EXCEL.

ou la méthode de Patrick qui est certainement la plus complète en terme de code et adapte a sub TESTENDOM3 Set PLAGE = Sheets(1).Range("A4:C" & Cells(Rows.Count, 1).End(xlUp).Row)'adqapter la plage ici

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
Sub TESTENDOM3()   
Dim PLAGE As Range, code As String, IE As Object
    Set PLAGE = Sheets(1).Range("A4:C" & Cells(Rows.Count, 1).End(xlUp).Row) 'adqapter la plage ici
    code = range_to_html_DOM3(PLAGE, True)
    Set IE = CreateObject("internetexplorer.application")
    With IE
        .Visible = True: .Left = 100: .Navigate "about:blank"    ' la position de la fenetre ie est en dehors du chanps de l'ecran (pas la peine dela voir ca n'est pas necessaire
        .Document.write code
    End With EndSub

Invité · 09/02/2017, 12h52

Bonjour,

Merci Patrick et Menhir pour l'intérêt que vous portez à mon problème et en lisant vos posts je me rend compte que vos connaissances sont "légèrement" supérieures aux miennes!

quel chance tu as;en ce qui me concerne elles sont nettement supérieur!

mais si tu veux t'affranchir du papier et de la corvée de l'impression fais un PDF!

la méthode de Patrick demande d'utiliser un enchaînement de fonction et même pas si ça ce trouve (prête à l'emploi)! mais juste de l'utiliser (en modifiant les paramètres à transmette) comme le code que je t'avais soumis!

code = range_to_html_DOM3(PLAGE, True)

**Marquisette65** · 09/02/2017, 13h04

oui je suis bien d'accord avec toi mais sincèrement je n'arrive pas à le faire fonctionner ton code!

à chaque fois il beug sur ".send", donc je n'ai pas du modifier correctement la sub test.

**Menhir** · 09/02/2017, 13h13

Envoyé par dysorthographie

mais si tu veux t'affranchir du papier et de la corvée de l'impression fais un PDF!

Je suis d'accord avec ça.

Tu commences ta macro en générant un (ou plusieurs) PDF à partir de tes feuilles (l'enregistreur automatique de macro devrait te donner un code presque tout fait).
Ensuite tu les mets en pièces jointes à ton mail.

Ca semble être le plus simple.

**Marquisette65** · 09/02/2017, 13h31

Merci beaucoup pour votre patiente!!!!!!

et je suis désolée j'ai cru que Menhir et dysorthographie vous étiez le même !

bon alors je teste ca tranquillement et je reviens vers vous...

encore merci !

Problème de Macro VBA pour envoyer un tableau avec sa mise en forme [XL-2007]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager