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

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?

**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 !

Invité · 09/02/2017, 13h42

Triskell

kenavo

**patricktoulon** · 09/02/2017, 13h57

re
oui Robert c'est prêt a l'emploi

Code :

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

1
2
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)

et tu met code ou tu veux dans le bodyhml du mail
et si la demoiselle préfère une simple image de la plage

je peut lui donner le moyen de placer l'image dans le bodyhtml et/ou en piece jointe

tout ca avec CDO bien entendu Outlook faut pas m'en parler

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

bon vous avez l'air tous d'accord mais pas mon ordi !
il y en aurait pas un de vous qui habite dans le sud ouest????

sérieusement, quel est le lien entre vos trois messages??? dysorthographie, menhir et patrick????

je mets la fonction de dysorthographie dans un module, ca c'est ok mais ensuite j'en fais quoi???

menhir tu me dis de générer un pdf (évidemment, je fais ça tous les matins en me brossant les cheveux!), je suppose que c'est dans mon menu, où je peux enregistrer en pdf... sauf que ça m'enregistre toute la feuille active, moi je ne voudrais qu'une sélection de cellules....

et patrick, "et tu met code ou tu veux dans le bodyhml du mail" euh de quel meil tu parles???

vraiment vous m'avez perdue entre la bretagne, les charentes et le var !

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

**Menhir** · 09/02/2017, 14h50

Envoyé par Marquisette65

menhir tu me dis de générer un pdf (évidemment, je fais ça tous les matins en me brossant les cheveux!), je suppose que c'est dans mon menu, où je peux enregistrer en pdf... sauf que ça m'enregistre toute la feuille active, moi je ne voudrais qu'une sélection de cellules....

ExportAsFixedFormat est une méthode de l'objet Range.
Il est donc possible de définir la plage concernée par la génération du PDF.
https://msdn.microsoft.com/fr-fr/lib.../ff836441.aspx
https://msdn.microsoft.com/fr-fr/lib.../ff195006.aspx

**patricktoulon** · 09/02/2017, 15h54

ceci sauve la plage A1:G10 sous le nom de toto.pdf sur ton bureau

Code :

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

1
2
3
4
5
6
7
Sub save_range_in_PDF()
chemin "C:\Users\" & environ("Username") & "\Desktop\"
 nom = "toto.pdf"
 Set plage = Range("A1:g10")
 plage.ExportAsFixedFormat Type:=xlTypePDF, Filename:=chemin & nom, Quality:=xlQualityMinimum, IncludeDocProperties:=True, _
 IgnorePrintAreas:=False, OpenAfterPublish:=False
 End Sub

re
bon la demoiselle
tu va faire un truc simple
prendre tout ce code et le mettre dans un module standard
pour le coup j'ai repris ton code de base pour CDO

une fois que tu a coller dans le module adapte ce qui est en VERT dans le code et c'est tout!!!!!
pour le test tu peut mettre ton propre email comme ca tu aura la possibilité de voir le résultat
résultat des courses tu aura la plage A1:K43 en pdf pour la pièce jointe et la même plage en html dans le body du html du mail

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
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
Sub Envois_récap()
 
Dim iMsg As Object, iConf As Object, Flds As Object, strHTML As String, i As Byte, j As Byte, nompdf As String
 
 nompdf = "C:\Users\" & Environ("Username") & "\Desktop\" & "toto.pdf"
 Set PLAGE = Range("A1:K43")
 PLAGE.ExportAsFixedFormat Type:=xlTypePDF, Filename:=nompdf, Quality:=xlQualityMinimum, IncludeDocProperties:=True, _
 IgnorePrintAreas:=False, OpenAfterPublish:=False
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields
 
strHTML = ""
strHTML = strHTML & "<HEAD>" & vbCrLf & "<BODY>" & "Bonjour, <BR><BR>vous trouverez ci joint le récap du mois.<BR><BR>"
strHTML = strHTML & range_to_html_DOM3(PLAGE, True)
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 = "trubidule@hotmail.fr"
    .From = "moimeme@hotmail.fr"
    .Subject = "test récap"
    .HTMLBody = strHTML
    .AddAttachment nompdf
    .Send
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

voila !!
un aperçu de ma boite de réception
Nom : Capture.JPG
Affichages : 255
Taille : 297,2 Ko

**Marquisette65** · 09/02/2017, 16h34

merci à tous pour explications !

Merci patrick pour ton travail !
mais même en copiant et en changeant juste mes adresses ça ne marche pas! il me sort une "erreur 1004 erreur définie par l'application ou par l'objet", regarde:

Nom : ecran1.png
Affichages : 223
Taille : 48,2 Ko

Nom : ecran1.png
Affichages : 223
Taille : 48,2 Ko

Qu'en penses tu?

**patricktoulon** · 09/02/2017, 16h42

re
c'est très étonnant!!!
il semblerait que tu utiliserais une variable pour 2 choses différentes

regarde bien si dans tes dim tu a pas une qui est pareil que moi si oui dis moi la quelle je ferait une adaptation au code

tu pourrais pas envoyé ton classeur en XLSX(sans macro) en remplaçant les nom et les email par du blablabla
comme ca on travaillerait sur le même fichier
j'attend ton retour

**Marquisette65** · 09/02/2017, 16h57

ben "Mes dim", je n'en ai pas, pour le coup je n'ai fais que copier ton code.

et oui voilà un extrait de mon fichier. merci encore!

**patricktoulon** · 09/02/2017, 17h04

ok je l'ai survolé je vais voir ca
il me faut savoir dans quel cellule tu va chercher les adresse mail pour envoyer

**Marquisette65** · 09/02/2017, 17h06

désolée, j'ai fais trois trucs en même temps et j'ai pas pris le bon, voici le .XLSX

pour l'instant je n'ai pas mis les adresses mails dans mon tableau, donc elles peuvent être n'importe où.
sachant qu'une feuille a une adresse mail. alors ça peut être dans cette feuille ou dans une autre où elles y seraient toutes? peu importe!

**patricktoulon** · 09/02/2017, 19h58

re
bon je suis passé a ma methode4 avec un webbrowser temporaire
test la sub pour elsa
n'oublie pas de mettre un bon email pour le destinataire
fichier exemple

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

Oh génial ça marche!!!!!!

**Marquisette65** · 16/02/2017, 13h09

bonjour,

depuis le 9 fev, je n'ai pas eu trop le temps mais ca y est, je me suis remise dans ma fameuse maccro !

Merci beaucoup Patrick !!!! ca fonctionne mais pourrions nous améliorer encore un peu plus? (oui je sais je suis exigeante :p)
pourrions nous envoyer la feuille en cours? et pourrions nous ajouter le mail du destinataire sur la feuille? cela éviterai d'aller modifier la maccro à chaque envois...

**Menhir** · 16/02/2017, 13h31

Envoyé par Marquisette65

Merci beaucoup Patrick !!!! ca fonctionne mais pourrions nous améliorer encore un peu plus? (oui je sais je suis exigeante :p)
pourrions nous envoyer la feuille en cours? et pourrions nous ajouter le mail du destinataire sur la feuille? cela éviterai d'aller modifier la maccro à chaque envois...

C'est étrange. Tu dis beaucoup "nous" mais tu ne montres pas vraiment ta participation à ce "nous"...

Ca donne plutôt l'impression que tu attends que les autres fassent le travail à ta place.

**Marquisette65** · 16/02/2017, 14h02

Merci Menhir pour ta remarque ça m'aide beaucoup !

simplement je connais mes limites et clairement ce code c'est Patrick qui l'a créé, j'en suis incapable.
mais j'essaye de le comprendre, j'ai d'ailleurs réussi à le modifier pour faire envoyer la feuille active, c'est peu être une banalité pour toi mais en tant que débutante c'est une vraie réussite!

**Menhir** · 16/02/2017, 14h21

Envoyé par Marquisette65

pourrions nous envoyer la feuille en cours?

j'ai d'ailleurs réussi à le modifier pour faire envoyer la feuille active

Quelle différence y a-t-il entre "la feuille active" et "la feuille en cours" ?
A part, bien sûr, le fait que tu ais réussi à traiter l'une mais que tu sois incapable (ce sont tes mots) de traiter l'autre ?

Envoyé par Marquisette65

simplement je connais mes limites et clairement ce code c'est Patrick qui l'a créé, j'en suis incapable.

C'est génétique comme incapacité ? Parce qu'aller regarder dans l'aide VBA pour connaitre les membres d'un objet, à ma connaissance, c'est à la portée de n'importe qui.
https://msdn.microsoft.com/fr-fr/lib.../ff866465.aspx

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

Macros et VBA Excel

Discussions similaires

Partager

Partager