Convertir la mise en forme d'une cellule excel en html

Version imprimable

07/11/2007, 14h02
ben_ghost

Convertir la mise en forme d'une cellule excel en html

Bonjour,

En gros j'aimerais obtenir pour une cellule contenant :

avant éxécution de la macro :

Code:

Je m appelle Ghost

aprés exécution de la macro :

Code:

je m appelle [ B]Ghost[ /B]

les données seront ensuite envoyé a un site internet mais il s'agit d'un progiciel je n'est donc pas la main sur celui.

je sais qu'il est possible d'enregistrer une page word au format HTML de ce fait y a t'il une fonction déjà existante la dessus ?

Merci

bonjour, le code pour enregistrer un classeur xls en htlm
Code:

1 2 3 ActiveWorkbook.SaveAs Filename:="C:\Users\XXXX\Desktop\Classeur1.htm", _ FileFormat:=xlHtml, ReadOnlyRecommended:=False, CreateBackup:=False
cordialement

Merci Fred mais ce n'est pas exactement ça que j'esperais mais j'ai réussi à me débrouillé tout seul en gros je voulais pouvoir convertir UNE cellule.

Donc j'ai du faire mon propre convertisseur. Le voila au cas ou certaines personnes serait interessé :

Code:

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
Sub CréationBalise()
    Dim cell As Range
 
    For Each cell In Selection
        Dim ColorDefault As Integer
        ColorDefault = -4105
        Dim d As Integer        ' counter
        Dim s As String         ' tanpom
        Dim B As Boolean        ' for BOLD
        Dim U As Boolean        ' for underline
        Dim I As Boolean        ' for Italic
        Dim C As Long           ' for Color
        C = ColorDefault
 
        s = "<html><body>"
        For d = 1 To Len(cell.Value) Step 1
            If cell.Characters(d, 1).Font.Bold = True Then                          ' Gestion Du gras
                If B = False Then                                                   '
                    s = s + "<b>"                                                   '
                    B = True                                                        '
                End If                                                              '
            End If                                                                  '
            If cell.Characters(d, 1).Font.Bold = False And B = True Then            '
                s = s + "</b>"                                                      '
                B = False                                                           '
            End If                                                                  '
 
            If cell.Characters(d, 1).Font.Underline = xlUnderlineStyleSingle Then                     ' Gestion du soulignement
                If U = False Then                                                   '
                    s = s + "<u>"                                                   '
                    U = True                                                        '
                End If                                                              '
            End If                                                                  '
            If cell.Characters(d, 1).Font.Underline = xlUnderlineStyleNone And U = True Then       '
                s = s + "</U>"                                                      '
                U = False                                                           '
            End If                                                                  '
 
            If cell.Characters(d, 1).Font.Italic = True Then                        ' Gestion de l'italique
                If I = False Then                                                   '
                    s = s + "<i>"                                                   '
                    I = True                                                        '
                End If                                                              '
            End If                                                                  '
            If cell.Characters(d, 1).Font.Italic = False And I = True Then          '
                s = s + "</i>"                                                      '
                I = False                                                           '
            End If                                                                  '
 
            If cell.Characters(d, 1).Font.ColorIndex <> ColorDefault Then           ' Gestion de la couleur
                Dim Rouge, Vert, Bleu As Integer
 
                Rouge = Int(cell.Characters(d, 1).Font.ColorIndex Mod 256)
                Vert = Int((cell.Characters(d, 1).Font.ColorIndex Mod 65536) / 256)
                Bleu = Int(cell.Characters(d, 1).Font.ColorIndex / 65536)
 
 
 
                If cell.Characters(d, 1).Font.ColorIndex <> C And C <> ColorDefault Then
                    s = s + "</font>"
                    s = s + "<font color=#""" + Format(Hex(Rouge), "##00") + Format(Hex(Vert), "##00") + Format(Hex(Bleu), "##00") + """>"
                    C = cell.Characters(d, 1).Font.ColorIndex                                                               '
                ElseIf C = ColorDefault And cell.Characters(d, 1).Font.ColorIndex <> ColorDefault Then
                    s = s + "<font color=#""" + Format(Hex(Rouge), "##00") + Format(Hex(Vert), "##00") + Format(Hex(Bleu), "##00") + """>"
                    C = cell.Characters(d, 1).Font.ColorIndex                                                        '
                End If
            End If
            If cell.Characters(d, 1).Font.ColorIndex = ColorDefault And C <> ColorDefault Then
                    s = s + "</font>"
                    C = ColorDefault
            End If '
 
            s = s + Right(Left(cell.Value, d), 1)
        Next
 
        If B = True Then
            s = s + "</b>"
            B = False
        End If
        If U = True Then
            s = s + "</u>"
            U = False
        End If
        If I = True Then
            s = s + "</i>"
            I = False
        End If
        If C <> ColorDefault Then     '
                s = s + "</font>"                                                      '
                C = ColorDefault                                                           '
        End If
 
        's = Replace(s, """", "&quot;")
        's = Replace(s, "&", "&amp;")
        ' Rétablissement des "&quot;", modifiés par la ligne RemplaceCar "&", "&amp;"
        's = Replace(s, "&amp;quot", "&quot")
        s = Replace(s, "à", "&agrave;")
        s = Replace(s, "é", "&eacute;")
        s = Replace(s, "è", "&egrave;")
        s = Replace(s, "ê", "&ecirc;")
        s = Replace(s, "î", "&icirc;")
        s = Replace(s, "ô", "&ocirc;")
        s = Replace(s, "ù", "&ugrave;")
 
        cell.Value = s + "</body></html>"
 
    Next
End Sub

07/08/2017, 18h28
patricktoulon

re

bonjour
cherche avec mon pseudo dans les contributions ma contrib grille to html
tu a tout dedans même la conversion code couleur excel en code couleur html

1 pièce(s) jointe(s)

Basé sur ma derniere contribution
voila ceci va te restitué dans un document html la meme chose en tout points (fontss,bold,italic,underline,couleur size)

Code:

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
Sub test()
MsgBox text_formaté(Cells(1, 1))
End Sub
Function Pt_To_Px()
With CreateObject("WScript.Shell"): Pt_To_Px = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72: End With
End Function
 
Public Function coul_XL_to_coul_HTMLX(couleur)
    Dim str0 As String, str As String
    Debug.Print couleur
    '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 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 = ""
    ppx = Pt_To_Px
    With Doc
        Set mot = .getelementbyid("mot")
        If IsDate(cel.Value) Then
            forma = cel.NumberFormat
            d = Trim(Replace(Format(cel.Value, forma), ",", ""))
            Set font = .createElement("FONT")
            font.innerhtml = IIf(cel.font.Italic, "<em>" & d & "</em>", Format(cel.Value, forma))
            font.innerhtml = IIf(cel.font.Bold, "<strong>" & font.innerhtml & "</strong>", d)
            font.Color = coul_XL_to_coul_HTMLX(cel.font.Color): font.face = cel.font.Name: font.Style.FontSize = Round(cel.font.Size * ppx) - 1 & "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 * ppx) & "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

Pièce jointe 301137

edit:modifie la derniere ligne de la fonction ligne par celle ci

Code:

text_formaté = Replace(Replace(mot.innerhtml, "", ""), "", "")

07/08/2017, 19h13
patricktoulon

re

re
les retours a la ligne dans une même cellule c'est le wraptext
ca existe aussi en html pour une balise div ou même cellule "<td>"
après une discussion récente dont je suis l'initiateur parle justement des lignes réelles ou pas dans une cellules dans la discussions il me semble avoir livré une fonction prêt a l'emploi

il te faut donc convertir un texte (wraptext) en texte avec saut de ligne dans la cellule excel ca change rien au visuel sur le tableau

après tu les passe a ma moulinette que je viens de présenter

et voila

Solution trouvée :-)

Je viens de trouver une solution pour convertir automatiquement, sous excel, le contenu de cellule(s) "texte" en "html", tout en conservant les retours à la ligne ("Alt" + "Entrée). Il suffit d'utiliser le code de "ben_ghost" et de rajouter à la fin de son code " s = Replace(s, vbLf, "") " pour les retours à la ligne. Son fonctionnement est un bon long, mais le résultat est au rendez-vous :-)

Voici son code avec la ligne de code supplémentaire :

Code:

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
Sub CréationBalise()
    Dim cell As Range
 
    For Each cell In Selection
        Dim ColorDefault As Integer
        ColorDefault = -4105
        Dim d As Integer        ' counter
        Dim s As String         ' tanpom
        Dim B As Boolean        ' for BOLD
        Dim U As Boolean        ' for underline
        Dim I As Boolean        ' for Italic
        Dim C As Long           ' for Color
        C = ColorDefault
 
        s = "<html><body>"
        For d = 1 To Len(cell.Value) Step 1
            If cell.Characters(d, 1).Font.Bold = True Then                          ' Gestion Du gras
                If B = False Then                                                   '
                    s = s + "<b>"                                                   '
                    B = True                                                        '
                End If                                                              '
            End If                                                                  '
            If cell.Characters(d, 1).Font.Bold = False And B = True Then            '
                s = s + "</b>"                                                      '
                B = False                                                           '
            End If                                                                  '
 
            If cell.Characters(d, 1).Font.Underline = xlUnderlineStyleSingle Then                     ' Gestion du soulignement
                If U = False Then                                                   '
                    s = s + "<u>"                                                   '
                    U = True                                                        '
                End If                                                              '
            End If                                                                  '
            If cell.Characters(d, 1).Font.Underline = xlUnderlineStyleNone And U = True Then       '
                s = s + "</U>"                                                      '
                U = False                                                           '
            End If                                                                  '
 
            If cell.Characters(d, 1).Font.Italic = True Then                        ' Gestion de l'italique
                If I = False Then                                                   '
                    s = s + "<i>"                                                   '
                    I = True                                                        '
                End If                                                              '
            End If                                                                  '
            If cell.Characters(d, 1).Font.Italic = False And I = True Then          '
                s = s + "</i>"                                                      '
                I = False                                                           '
            End If                                                                  '
 
            If cell.Characters(d, 1).Font.ColorIndex <> ColorDefault Then           ' Gestion de la couleur
                Dim Rouge, Vert, Bleu As Integer
 
                Rouge = Int(cell.Characters(d, 1).Font.ColorIndex Mod 256)
                Vert = Int((cell.Characters(d, 1).Font.ColorIndex Mod 65536) / 256)
                Bleu = Int(cell.Characters(d, 1).Font.ColorIndex / 65536)
 
 
 
                If cell.Characters(d, 1).Font.ColorIndex <> C And C <> ColorDefault Then
                    s = s + "</font>"
                    s = s + "<font color=#""" + Format(Hex(Rouge), "##00") + Format(Hex(Vert), "##00") + Format(Hex(Bleu), "##00") + """>"
                    C = cell.Characters(d, 1).Font.ColorIndex                                                               '
                ElseIf C = ColorDefault And cell.Characters(d, 1).Font.ColorIndex <> ColorDefault Then
                    s = s + "<font color=#""" + Format(Hex(Rouge), "##00") + Format(Hex(Vert), "##00") + Format(Hex(Bleu), "##00") + """>"
                    C = cell.Characters(d, 1).Font.ColorIndex                                                        '
                End If
            End If
            If cell.Characters(d, 1).Font.ColorIndex = ColorDefault And C <> ColorDefault Then
                    s = s + "</font>"
                    C = ColorDefault
            End If '
 
            s = s + Right(Left(cell.Value, d), 1)
        Next
 
        If B = True Then
            s = s + "</b>"
            B = False
        End If
        If U = True Then
            s = s + "</u>"
            U = False
        End If
        If I = True Then
            s = s + "</i>"
            I = False
        End If
        If C <> ColorDefault Then     '
                s = s + "</font>"                                                      '
                C = ColorDefault                                                           '
        End If
 
        's = Replace(s, """", """)
        's = Replace(s, "&", "&amp;")
        ' Rétablissement des """, modifiés par la ligne RemplaceCar "&", "&amp;"
        's = Replace(s, "&amp;quot", "&quot")
        s = Replace(s, "à", "&agrave;")
        s = Replace(s, "é", "&eacute;")
        s = Replace(s, "è", "&egrave;")
        s = Replace(s, "ê", "&ecirc;")
        s = Replace(s, "î", "&icirc;")
        s = Replace(s, "ô", "&ocirc;")
        s = Replace(s, "ù", "&ugrave;")
        s = Replace(s, vbLf, "</p>")

        cell.Value = s + "</body></html>"
 
    Next
End Sub

08/08/2017, 17h02
patricktoulon

1 pièce(s) jointe(s)

re

le problème dans cette démarche c'est que si ta cellule est en propriété ajuster a la ligne automatiquement (wraptext)
on a donc plusieurs saut de lignes dans la cellules visible mais tu ne les trouvera pas en examinant le texte
c'est ce que j'essai de t'expliquer en vain me semble t il ;)

Pièce jointe 301502

et attention les balise b et i sont amené a disparaitre du html elles sont remplacé par strong et EM
02/06/2024, 17h00
chercao

Preneuse de vos infos

Bonjour, je cherche aussi a transformer un texte d'une cellule excel en texte html dans une nouvelle cellule, mais je ne suis pas développeuse. Je suis tombée sur vos propositions et cela m'intéresse de faire la même chose.

Pourrions nous en discuter ?
Caroline

1 pièce(s) jointe(s)

Bonjour
excel donne déjà la chose avec le .value(11)
reste plus qu'à faire un peu de netoyage dans le texte

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Function htmltexte(cel As Range)
'Fonction de récupération du code html du texte formaté dans la cellule
'Patricktoulon (2016)
    Dim cde$, elem, Dc As New HTMLDocument
    cde = Replace(Replace(Replace(cel.Value(11), "ss:", ""), "Data", "Div"), "html:", "")
    cde = Replace(cde, "
", "<br>")
    With Dc
        .body.innerhtml = cde
        For Each elem In .all
            If elem.getattribute("size") <> "" Then elem.Style.FontSize = elem.getattribute("size") & "pt"
            elem.removeattribute ("size")
        Next
        htmltexte = .getelementsbytagname("div")(0).innerhtml
    End With
End Function

la formule
exemple
=htmltexte(A1]

corrige la secondes lide "cde=..." il y a la chaine du saut de ligne qui passe pas dans le post
Pièce jointe 656154