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
|
Option Explicit
Function plage_to_HTML(plage As Range) As String
Dim TD, TR, DOC, DICO, Table As Object, i As Long, col As Long, cel As Range
Set DICO = CreateObject("scripting.dictionary")
Set DOC = CreateObject("htmlfile")
With DOC
.body.innerhtml = "<Table></Table>"
Set Table = .getelementsbytagname("Table")(0)
Table.Style.Width = Round(plage.Width * (4 / 2.3))
Table.Style.Height = Round(plage.Height * 1.75)
Table.Style.bordercollapse = "collapse"
For i = 1 To plage.Rows.Count
Set TR = .createelement("TR")
For col = 1 To plage.Columns.Count
Set cel = plage.Cells(i, col)
If Not DICO.exists(cel.MergeArea.Address) Then
DICO(cel.MergeArea.Address) = ""
Set TD = .createelement("TD")
With TD
.ID = cel.Address: .colspan = cel.MergeArea.Columns.Count: .rowspan = cel.MergeArea.Rows.Count
.innerhtml = IIf(cel.Value <> "", text_BYSPAN_format(cel), " ")
With .Style
'.FontSize = Round(cel.Font.Size * 1.8) & "px"
.fontfamily = cel.Font.Name
.fontweight = IIf(cel.Font.Bold = True, "Bold", "Normal")
.FontStyle = IIf(cel.Font.Italic = True, "italic", "normal")
.Color = coul_XL_to_coul_HTMLX(cel.Font.Color)
.bordertop = borderstyle(cel.borders(xlEdgeTop))
.borderleft = borderstyle(cel.borders(xlEdgeLeft))
.borderbottom = borderstyle(cel.borders(xlEdgeBottom))
.borderright = borderstyle(cel.borders(xlEdgeRight))
.Width = Round(cel.Width * 1.5)
.Height = Round(cel.Height * 1.5) & "px"
.Background = coul_XL_to_coul_HTMLX(cel.Interior.Color)
End With
End With
TR.appendchild (TD)
End If
Next
Table.appendchild (TR)
Next
plage_to_HTML = .body.innerhtml
End With
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
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")
If Cote.LineStyle = xlDash And Cote.Weight = xlThick Then borderweight = 3 ' xldash et epaisseur xlthick 'Tiret en pointillet
If Cote.LineStyle = xlDash And Cote.Weight = xlThin Then borderweight = 2:: bstyle = "dotted" 'point en pointillet
If Cote.LineStyle = xlDashDotDot Then borderweight = 3 'xlDashDotDot
bcolor = coul_XL_to_coul_HTMLX(Cote.Color)
borderstyle = borderweight & bstyle & " " & bcolor
If Cote.LineStyle = xlNone Then borderstyle = "0.3pt solid #A9D0F5"
End Function
Function text_BYSPAN_format(c)
'formatage du texte de la cellule html identiquement a la cellule excel
Dim p As Object, oldspan As Object, i As Long, L
text_BYSPAN_format = ""
With CreateObject("htmlfile")
.body.innerhtml = "<div id =T><SPAN> </SPAN></div>"
Set p = .getelementbyid("T")
Set oldspan = .getelementsbytagname("SPAN")(0)
For i = 1 To Len(c.Value)
Set L = .createelement("span")
L.Style.Color = coul_XL_to_coul_HTMLX(c.Characters(Start:=i, Length:=1).Font.Color)
L.Style.FontSize = Round(c.Font.Size + 7) & "px"
L.Style.fontfamily = c.Characters(Start:=i, Length:=1).Font.Name
L.Style.fontweight = IIf(c.Characters(Start:=i, Length:=1).Font.Bold = True, "Bold", "Normal")
L.Style.FontStyle = IIf(c.Characters(Start:=i, Length:=1).Font.Italic = True, "italic", "normal")
If Split(L.outerhtml, ">")(0) <> Split(oldspan.outerhtml, ">")(0) Then
L.innertext = c.Characters(Start:=i, Length:=1).Text
p.appendchild (L)
Set oldspan = L
Else
oldspan.innertext = oldspan.innertext & c.Characters(Start:=i, Length:=1).Text
End If
Next
text_BYSPAN_format = " " & .getelementsbytagname("div")(0).innerhtml
End With
End Function
Sub test_byspan()
text_BYSPAN_format ([b4])
Set IE = CreateObject("internetexplorer.application")
IE.Visible = True
IE.navigate "about:blank"
IE.document.body.innerhtml = text_BYSPAN_format([b4])
End Sub |
