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
| Sub FormatHTMLInExcel()
Dim cell As Range
Set cell = Range("A4")
cell.Clear
' Récupérer le texte HTML depuis A1
html = Range("A1").Value
If Trim(html) = "" Then
MsgBox "Veuillez entrer du texte HTML dans A1.", vbExclamation
Exit Sub
End If
' Pré-traitement : remplacer <br> par vbCrLf et supprimer <p> et </p>
html = Replace(html, "<br>", vbCrLf)
Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")
regex.Global = True
regex.IgnoreCase = True
regex.Pattern = "<p>|</p>"
html = regex.Replace(html, "")
' Expression régulière pour capturer balises et texte
regex.Pattern = "(<b>|</b>|<i>|</i>|<u>|</u>|<font [^>]*>|</font>|<strike>|</strike>)|([^<>]+)"
Dim matches As Object
Set matches = regex.Execute(html)
Dim fullText As String
fullText = ""
Dim formatRanges As Collection
Set formatRanges = New Collection
Dim pos As Long
pos = 1
Dim isBold As Boolean, isItalic As Boolean, isUnderline As Boolean, isStrike As Boolean
Dim fontColor As String, fontSize As Long
Dim startPos As Long
Dim textPart As String, match As Object
For Each match In matches
textPart = match.Value
If Left(textPart, 1) = "<" Then
Select Case LCase(textPart)
Case "<b>"
isBold = True
Case "</b>"
isBold = False
Case "<i>"
isItalic = True
Case "</i>"
isItalic = False
Case "<u>"
isUnderline = True
Case "</u>"
isUnderline = False
Case "<strike>"
isStrike = True
Case "</strike>"
isStrike = False
Case Else
If Left(LCase(textPart), 5) = "<font" Then
' Extraire couleur
Dim colorRegex As Object
Set colorRegex = CreateObject("VBScript.RegExp")
colorRegex.Pattern = "color=[""']?(#[0-9A-Fa-f]{6}|[a-zA-Z]+)[""']?"
Dim colorMatch As Object
Set colorMatch = colorRegex.Execute(textPart)
If colorMatch.Count > 0 Then
fontColor = Mid(colorMatch(0).Value, InStr(colorMatch(0).Value, "=") + 1)
fontColor = Replace(Replace(fontColor, """", ""), "'", "")
End If
' Extraire taille
Dim sizeRegex As Object
Set sizeRegex = CreateObject("VBScript.RegExp")
sizeRegex.Pattern = "size=[""']?([0-7])[""']?"
Dim sizeMatch As Object
Set sizeMatch = sizeRegex.Execute(textPart)
If sizeMatch.Count > 0 Then
Dim sizeValue As String
sizeValue = Mid(sizeMatch(0).Value, InStr(sizeMatch(0).Value, "=") + 1)
sizeValue = Replace(Replace(sizeValue, """", ""), "'", "") ' Supprimer les guillemets
fontSize = CInt(sizeValue)
End If
ElseIf LCase(textPart) = "</font>" Then
fontColor = ""
fontSize = 0
End If
End Select
Else
' Ajouter le texte à fullText
fullText = fullText & textPart
startPos = pos
pos = pos + Len(textPart)
' Enregistrer la mise en forme pour cette portion de texte
formatRanges.Add Array(startPos, Len(textPart), isBold, isItalic, isUnderline, isStrike, fontColor, fontSize)
End If
Next match
' Insérer tout le texte dans la cellule
cell.Value = fullText
cell.WrapText = True
' Appliquer les mises en forme
Dim formatRange As Variant
For Each formatRange In formatRanges
Dim start As Long, length As Long
start = formatRange(0)
length = formatRange(1)
With cell.Characters(start, length).Font
.Bold = formatRange(2)
.Italic = formatRange(3)
.Underline = IIf(formatRange(4), xlUnderlineStyleSingle, xlUnderlineStyleNone)
.Strikethrough = formatRange(5)
If formatRange(6) <> "" Then
Select Case LCase(formatRange(6))
Case "red"
.Color = RGB(255, 0, 0)
Case "green"
.Color = RGB(0, 128, 0)
Case "blue"
.Color = RGB(0, 112, 198)
Case "black"
.Color = RGB(0, 0, 0)
Case "yellow"
.Color = RGB(255, 255, 0)
' Ajouter d'autres couleurs si nécessaire
End Select
End If
If formatRange(7) > 0 Then
Select Case formatRange(7)
Case 1: .Size = 8
Case 2: .Size = 10
Case 3: .Size = 12
Case 4: .Size = 14
Case 5: .Size = 18
End Select
End If
End With
Next formatRange
cell.Rows.AutoFit
Range("A4:C4").Merge
End Sub |
