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 |
Partager