Discussion :

[Areis]

Bonjour,

Je reçois un fichier Excel de la part d'un développeur qui contient un grand nombre de cellules avec les balises de mise en forme html (<b>gras</b>, <i>italique</i> et <u>souligné</u>). Je voudrais faire une macro VBA pour identifier ces différentes balises et recopier (dans la cellule d'à côté) le texte sans les balises mais en avec la mise en forme.

Je ne suis pas très à l'aise avec le VBA donc je n'arrive pas à tout faire... J'ai pu faire une macro qui ajoute la mise en forme mais je ne sais pas comment supprimer les balises . Voici l'état actuel de ma macro (le même code est appliqué 3 fois pour chaque type de mise en forme) :

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
Sub Lecture_Balises()
 
    ' Définir le texte initial
    TexteTempo = ActiveCell.Value
 
    ' Nombre de caractère du texte initial
    TexteTempoNbCar = Len(TexteTempo)
'    ActiveCell.Offset(0, 2).Value = TexteTempoNbCar
    ActiveCell.Offset(0, 1).Value = TexteTempo
    ActiveCell.Offset(0, 1).Select
 
    For i = 1 To TexteTempoNbCar - 7
 
        ' Repérer le début de la balise
        If Mid(TexteTempo, i, 3) = "<b>" Then
            For j = 1 To TexteTempoNbCar - 3 - i
 
                ' Repérer la fin de la balise
                If Mid(TexteTempo, i + j, 4) = "</b>" Then
 
                    ' Fixer le style entre les deux balises
                    ActiveCell.Characters(Start:=i, Length:=j + 4).Font.FontStyle = "Gras"
                    j = TexteTempoNbCar - 3 - i ' Ne pas continuer la chaîne de caractère pour avoir les informations entre deux séries de balises
                    End If
                Next j
            End If
 
        ' Repérer le début de la balise
        If Mid(TexteTempo, i, 3) = "<i>" Then
            For k = 1 To TexteTempoNbCar - 3 - i
 
                ' Repérer la fin de la balise
                If Mid(TexteTempo, i + k, 4) = "</i>" Then
 
                    ' Fixer le style entre les deux balises
                    ActiveCell.Characters(Start:=i, Length:=k + 4).Font.FontStyle = "Italique"
                    k = TexteTempoNbCar - 3 - i ' Ne pas continuer la chaîne de caractère pour avoir les informations entre deux séries de balises
                    End If
                Next k
            End If
 
        ' Repérer le début de la balise
        If Mid(TexteTempo, i, 3) = "<u>" Then
            For l = 1 To TexteTempoNbCar - 3 - i
 
                ' Repérer la fin de la balise
                If Mid(TexteTempo, i + l, 4) = "</u>" Then
 
                    ' Fixer le style entre les deux balises
                    ActiveCell.Characters(Start:=i, Length:=l + 4).Font.Underline = xlUnderlineStyleSingle
                    l = TexteTempoNbCar - 3 - i ' Ne pas continuer la chaîne de caractère pour avoir les informations entre deux séries de balises
                    End If
                Next l
            End If
    Next i
End Sub

Existe-t-il une solution simple me permettant de supprimer ces balises ? J'ai tenté de "reconstruire mon champ texte" en enlevant les balises (avec des "&" et en prenant les longueurs de caractères adéquates) mais les mises en forme effectuées précédemment ne sont pas conservées.

Il faut aussi que je fasse la macro inverse (ajouter les balises html en identifiant la mise en forme du texte dans une cellule), mais je me pencherai dessus quand la première fonctionnera déjà

Un grand merci

[taquatzieu]

Bonjour,
Ma réponse est peut-être simpliste, mais ne serait-il pas plus simple d'utiliser la fonction de remplacement ?

[Areis]

Bonjour,
Ma réponse est peut-être simpliste, mais ne serait-il pas plus simple d'utiliser la fonction de remplacement ?

Si tu parler du "remplacer" d'édition (Ctr+H quoi, je ne sais pas quel est son nom savant... ), ça ne fonctionne pas : on perd toute mise en forme (ou plutôt la mise en forme du premier caractère est utilisée pour toute la cellule).

S'il s'agit d'une autre fonction je ne connais pas et ça m'intéresse grandement ! :-p

[taquatzieu]

Je parlais bien de cette fonction là effectivement.
Si j'ai bien compris, ne peux tu pas coller ta colonne avec les balises dans la colonne à coté, faire les remplacements des balises et ensuite reprendre la mise en forme de la colonne initiale ?

[Phil'oche]

Bonjour,

Avec par exemple le contenu de la cellule :

Code :

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

Il faut aussi que je <b>fasse la macro</b> inverse (<b><i>ajouter les balises</i></b> html en identifiant la mise en forme du texte dans une <i><u>cellule</u></i>), mais je me pencherai <u>dessus quand</u> la première fonctionnera déjà.

Voilà comment je le traiterais :
- on crée un ensemble de paires (tableau à 2 dimensions ?) contenant la liste des positions des débuts et fin de chacune des balises (B,I et U)
- on purge la valeur de cette balise
- on applique la mise en forme en reprenant les positions début/fin des 3 tableaux

Petit bout de code fait à l'arrache :

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
Public Sub HTMLtoFormattedText(OldTxt As String)
 
Dim NbBold As Integer, NbItalic As Integer, NbUnderline As Integer
Dim posBold() As Variant, posItalic() As Variant, posUnderline() As Variant
Dim NewTxt As String
 
NewTxt = OldTxt
 
NbBold = UBound(Split(OldTxt, "<b>"))           ' compte le nombre de balises B
NbItalic = UBound(Split(OldTxt, "<i>"))         ' compte le nombre de balises I
NbUnderline = UBound(Split(OldTxt, "<u>"))      ' compte le nombre de balises U
 
If NbBold > 0 Then
    ReDim posBold(1 To NbBold, 1 To 2)          ' redimensionne le tableau des débuts/fins de balise B
    posBold(1, 1) = InStr(1, NewTxt, "<b>")     ' position du 1er début de balise B
    NewTxt = Replace(NewTxt, "<b>", "", , 1)    ' on efface cette balise (1 seule fois)
    posBold(1, 2) = InStr(1, NewTxt, "</b>")    ' position de la 1ere fin de balise B
    NewTxt = Replace(NewTxt, "</b>", "", , 1)   ' on efface cette balise (1 seule fois)
    For i = 2 To NbBold                         ' on boucle sur les balises suivantes en effaçant au fur et à mesure
        posBold(i, 1) = InStr(posBold(i - 1, 1) + 1, NewTxt, "<b>")
        NewTxt = Replace(NewTxt, "<b>", "", , 1)
        posBold(i, 2) = InStr(posBold(i - 1, 2) + 1, NewTxt, "</b>")
        NewTxt = Replace(NewTxt, "</b>", "", , 1)
    Next i
 
End If
 
' faire de même pour les balises U et I
' puis coller la valeur dans macellule et appliquer chaque mise en forme
' par Range(macellule).Characters(Début, Longueur).Font.FontStyle = "Gras"
' avec debut = posBold(i, 1) et longueur = posBold(i, 2) - posBold(i, 1)
 
End Sub

Reste à régler le problème des balises imbriquées, car ça va provoquer un décallage...

[patricktoulon]

Bonsoir

regarde comment on applique le format tel que dans le html

Code :

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

1
2
3
4
5
6
7
8
9
10
Function html_transform_into_VBA(cel)
With CreateObject("htmlfile")
.body.innerhtml = cel.Value
r = .parentwindow.clipboardData.setData("Text", "<table><tr><td>" & cel.Text & "</td></tr></table>")
With cel.Parent: .Activate: cel.Select: .Paste: End With
End With
End Function
Sub test()
html_transform_into_VBA ActiveCell
End Sub

tout les format de font couleur bold italic underline exposant etc... seront restitués

[patricktoulon]

et si tu tiens absolument a le faire avec un algo meme avec des balises imbriquées
une ebauche

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
Sub testx()
    texte = [A17].Text
    ReDim tabloB(Len(texte) + 1, 6)
     a = -1
    If Right(texte, 1) = ">" Then l = Len(texte) - 4 Else l = Len(texte)
    For Z = 1 To l
        If Mid(texte, Z, 3) = "<b>" Then b = "b": Z = Z + 3
        If Mid(texte, Z, 4) = "</b>" Then b = "": Z = Z + 4
        If Mid(texte, Z, 3) = "<i>" Then i = "i": Z = Z + 3
        If Mid(texte, Z, 4) = "</i>" Then i = "": Z = Z + 4
        If Mid(texte, Z, 3) = "<u>" Then u = "u": Z = Z + 3
        If Mid(texte, Z, 4) = "</u>" Then u = "": Z = Z + 4
 
        a = a + 1
        t = t & Mid(texte, Z, 1)
        tabloB(a, 0) = b
        tabloB(a, 1) = i
        tabloB(a, 2) = u
        tabloB(a, 5) = Mid(texte, Z, 1)
    Next
    With [A18]
        .Value = IIf(Right(t, 1) = "<", Mid(t, 1, Len(t) - 1), t)
        For i = 0 To UBound(tabloB)
            If tabloB(i, 0) = "b" Then .Characters(Start:=i + 1, Length:=1).Font.Bold = True
            If tabloB(i, 1) = "i" Then .Characters(Start:=i + 1, Length:=1).Font.Italic = True
            If tabloB(i, 2) = "u" Then .Characters(Start:=i + 1, Length:=1).Font.Underline = xlUnderlineStyleSingle
        Next
    End With
   End Sub

demo ligne 17 et 18

[Areis]

Voilà comment je le traiterais :
- on crée un ensemble de paires (tableau à 2 dimensions ?) contenant la liste des positions des débuts et fin de chacune des balises (B,I et U)
- on purge la valeur de cette balise
- on applique la mise en forme en reprenant les positions début/fin des 3 tableaux

Merci Phil'oche : j'ai regardé ton code et essayé de l'appliquer mais je ne m'en suis pas sorti (il y a trop de passages où je ne comprends pas du tout la syntaxe...)

regarde comment on applique le format tel que dans le html

tout les format de font couleur bold italic underline exposant etc... seront restitués

Ce code est d'une étonnante simplicité ! Par contre j'avoue que je n'y comprends quasi-rien en regardant étape par étape (même si c'est très court)... (je ne sais donc pas comment le modifier). J'aurais donc beaucoup de questions (sans doute très bêtes) qui sont une conséquence de mon niveau très basique en VBA... Notamment toute mise en forme (police, taille de police, cadre, fond et même mise en forme conditionnelle) est supprimée dans la cellule. Sur ma feuille elle revient à calibri taille 10, noir sur fond blanc, sans mise en forme conditionnelle... Est-ce un paramètre que l'on peut conserver ?

Je ne pense pas que j'aurais des balises imbriquées mais j'ai regardé ton code suivant (qui me parle un peu plus du coup...) et il a l'avantage de conserver la mise en forme (incluant les conditionnelles) de la cellule d'arrivée donc je vais plutôt utiliser celui-là.

Un grand merci à vous d'avoir consacré du temps à me répondre !

Je laisse le fuseau ouvert : je vais tenter d'appliquer ces morceaux de code pour le sens html=>Excel puis je regarde si je peux l'utiliser pour faire l'inverse (ajouter les balises html en prenant en compte la mise en forme dans la cellule) et je viens rajouter une couche si je ne m'en sors pas

[Areis]

Je parlais bien de cette fonction là effectivement.
Si j'ai bien compris, ne peux tu pas coller ta colonne avec les balises dans la colonne à coté, faire les remplacements des balises et ensuite reprendre la mise en forme de la colonne initiale ?

J'avais zappé cette réponse, désolé . Oui c'est sans doute faisable effectivement, je regarde si je ne m'en sors pas avec les autres aides qui ont été proposées. merci

[patricktoulon]

bonjour

mon exemple et simple
on boucle sue le len (chaque caracteres)et on teste les 3 ou 4 caracteres si il coorespondent a une balise
si c est le cas on prend le caractere 3 ou 4 plus loin et on le met au foormat corespondant a la balise
dans cette meme boucle si on tombe sur la balise de fermeture on met le caractere sans le format de cette balise


pour faire l'inverse c'est a dire editer un code html correspondant a ce que tu a dans ta cellule tu peux utiliser le .Value(xlRangeValueXMLSpreadsheet)qui te donne lme code html correspondant a ta cellule si il y a au moins deux formats differents dans la balise "DATA" fille de la balise CELL dans le xml

[patricktoulon]

un exemple hyper simple pour recuperer le code html d'une cellule excel j'ai mis le paquet de plein de chose

Code :

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

1
2
3
4
5
6
7
Sub test()
codexml = Replace(Replace(ActiveCell.Value(xlRangeValueXMLSpreadsheet), "html:", ""), "ss:", "")
With CreateObject("htmlfile")
.body.innerhtml = Replace(Replace(codexml, "<Data", "<pre  id =xx"), "Data>", "pre>")
MsgBox .getelementbyid("xx").innerhtml
End With
End Sub

regarde

[patricktoulon]

pettite correction des fontsize en html --->>> css

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
Sub test()
codexml = Replace(Replace(ActiveCell.Value(xlRangeValueXMLSpreadsheet), "html:", ""), "ss:", "")
With CreateObject("htmlfile")
.body.innerhtml = Replace(Replace(codexml, "<Data", "<pre  id =xx"), "Data>", "pre>")
'petite corection des fontsize en convertissant la propriété size des balises font en propriétés "CSS font-size"
Set Fonts = .getelementbyid("xx").getelementsbytagname("FONT")
For i = 0 To Fonts.Length - 1
If IsNumeric(Fonts(i).Size) Then Fonts(i).Style.FontSize = Fonts(i).Size & "pt"
Next
MsgBox .getelementbyid("xx").innerhtml
End With
End Sub

[Areis]

pour faire l'inverse c'est a dire editer un code html correspondant a ce que tu a dans ta cellule tu peux utiliser le .Value(xlRangeValueXMLSpreadsheet)qui te donne lme code html correspondant a ta cellule si il y a au moins deux formats differents dans la balise "DATA" fille de la balise CELL dans le xml

Bonjour Patrick,

J'ai développé un programme avant de lire ta réponse et le détail de cette syntaxe ; je ne doute pas que mon programme soit beaucoup moins élégant mais tout fonctionne bien j'ai réussi à m'en sortir.

Je mets quand même mon code de bourrin :

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
Sub Vers_html_Cellule()
    ' Définir le texte initial
    TexteInitial = ActiveCell.Value
 
    ' Nombre de caractère du texte initial
    TexteInitialnbCar = Len(TexteInitial)
'    ActiveCell.Offset(0, 2).Value = TexteInitialnbCar
    ActiveCell.Offset(0, 1).Value = TexteInitial
 
    ' Variable pour connaître le nombre de caractères ajoutés à la chaîne suite aux nombres de balises html rajoutées (afin d'identifier les caractères de la chaîne)
    j = 0
 
    For i = 1 To TexteInitialnbCar
 
    ' Début de chaîne
        ' "Gras"
        If (i = 1 And ActiveCell.Characters(Start:=1, Length:=1).Font.FontStyle = "Gras") Or (ActiveCell.Characters(Start:=i - 1, Length:=1).Font.FontStyle <> "Gras" And ActiveCell.Characters(Start:=i, Length:=1).Font.FontStyle = "Gras") Then
            TextePre = Mid(ActiveCell.Offset(0, 1).Value, 1, i - 1 + j)
            ActiveCell.Offset(0, 1).Value = TextePre & "<b>" & Mid(TexteInitial, i, TexteInitialnbCar)
            j = j + 3
            End If
 
        ' "Italique"
        If (i = 1 And ActiveCell.Characters(Start:=1, Length:=1).Font.FontStyle = "Italique") Or (ActiveCell.Characters(Start:=i - 1, Length:=1).Font.FontStyle <> "Italique" And ActiveCell.Characters(Start:=i, Length:=1).Font.FontStyle = "Italique") Then
            TextePre = Mid(ActiveCell.Offset(0, 1).Value, 1, i - 1 + j)
            ActiveCell.Offset(0, 1).Value = TextePre & "<i>" & Mid(TexteInitial, i, TexteInitialnbCar)
            j = j + 3
            End If
 
        ' "Souligné"
        If (i = 1 And ActiveCell.Characters(Start:=1, Length:=1).Font.Underline = xlUnderlineStyleSingle) Or (ActiveCell.Characters(Start:=i - 1, Length:=1).Font.Underline <> xlUnderlineStyleSingle And ActiveCell.Characters(Start:=i, Length:=1).Font.Underline = xlUnderlineStyleSingle) Then
            TextePre = Mid(ActiveCell.Offset(0, 1).Value, 1, i - 1 + j)
            ActiveCell.Offset(0, 1).Value = TextePre & "<u>" & Mid(TexteInitial, i, TexteInitialnbCar)
            j = j + 3
            End If
 
    ' Fin de chaîne
        ' "Gras"
        If ActiveCell.Characters(Start:=i - 1, Length:=1).Font.FontStyle = "Gras" And ActiveCell.Characters(Start:=i, Length:=1).Font.FontStyle <> "Gras" Then
            TextePre = Mid(ActiveCell.Offset(0, 1).Value, 1, i - 1 + j)
            ActiveCell.Offset(0, 1).Value = TextePre & "</b>" & Mid(TexteInitial, i, TexteInitialnbCar)
            j = j + 4
            End If
 
        ' "Italique"
        If ActiveCell.Characters(Start:=i - 1, Length:=1).Font.FontStyle = "Italique" And ActiveCell.Characters(Start:=i, Length:=1).Font.FontStyle <> "Italique" Then
            TextePre = Mid(ActiveCell.Offset(0, 1).Value, 1, i - 1 + j)
            ActiveCell.Offset(0, 1).Value = TextePre & "</i>" & Mid(TexteInitial, i, TexteInitialnbCar)
            j = j + 4
            End If
 
        ' "Souligné"
        If ActiveCell.Characters(Start:=i - 1, Length:=1).Font.Underline = xlUnderlineStyleSingle And ActiveCell.Characters(Start:=i, Length:=1).Font.Underline <> xlUnderlineStyleSingle Then
            TextePre = Mid(ActiveCell.Offset(0, 1).Value, 1, i - 1 + j)
            ActiveCell.Offset(0, 1).Value = TextePre & "</u>" & Mid(TexteInitial, i, TexteInitialnbCar)
            j = j + 4
            End If
 
    Next i
 
' Fin de cellule (ordre inversé de prise en compte pour que ça fonctionne sans croisement de balise)
 
    ' "Souligné"
    If ActiveCell.Characters(Start:=TexteInitialnbCar, Length:=1).Font.Underline = xlUnderlineStyleSingle Then
        ActiveCell.Offset(0, 1).Value = ActiveCell.Offset(0, 1).Value & "</u>"
        End If
 
    ' "Italique"
    If ActiveCell.Characters(Start:=TexteInitialnbCar, Length:=1).Font.FontStyle = "Italique" Then
        ActiveCell.Offset(0, 1).Value = ActiveCell.Offset(0, 1).Value & "</i>"
        End If
 
    ' "Gras"
    If ActiveCell.Characters(Start:=TexteInitialnbCar, Length:=1).Font.FontStyle = "Gras" Then
        ActiveCell.Offset(0, 1).Value = ActiveCell.Offset(0, 1).Value & "</b>"
        End If
 
End Sub

Merci à tous pour votre aide ; je clos le sujet

[patricktoulon]

et oui mais non
selon comment tes balises Italic ou Underline ou Bold seront imbriqués ca te sautera une fermeture

il y a beaucoup beaucoup plus simple mais alors hypersimple
puique tu veux le faire dans des boucle avant et arriere je te propose une seule boucle et on va proceder comme les fonctions texte dans un wysiwyg(editeur html)
a savoir insert before mais la on va faire tout en string c'est a dire prendre la balise suivante et voir si c'est pas la meme que la precedente
mais pour cela chaque caracteres doit etre entre balise au depart
au quel cas les deux balise peuvent en former q'une seule tout simplement en replacant par exemple "</em<em>" par rien ou encore "</b><b>" par rien

ainsi j'ai dans ma cellulule

toto mange des bannanes

j'obtiens par ma methode ceci:

to<b><u>t</u></b><b><u>o</u></b><b><u> </u></b>ma<em><b>n</b></em><em><b>g</b></em><em><b>e</b></em> des <em><b><u>b</u></b></em><em><b><u>a</u></b></em><em><b><u>n</u></b></em>nanes

autrement dis chaque caracteres est englobé dans les balises "bold si il est gras italic si il l'est ect......
il ne reste plus maintenant qu'a proceder comme le ferait insertbeforeen dom javascript et meme en dom VB c'est adire rassembler les balises identiques qui se suivent
on obtient donc avec le replace

to<b><u>to </u></b>ma<em><b>nge</b></em> des <em><b><u>ban</u></b></em>nanes

et voila c'est magique

et pour cela un code on ne peut plus simple que voici j'en ai meme fait une fonction
regarde bien comment je travaille tes balises en amont avant d'ecrire le texte
c'est la seule methode qui te garantira un resultat corecte a chaque coup le wysiwyg je connais tres bien

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
Function cell_to_html(cel As Range)
    Dim b, bfin, it, itfin, soul, soulfin
    For i = 1 To Len(cel.Text)
        If cel.Characters(Start:=i, Length:=1).Font.FontStyle Like "*italique*" Then it = "<em>": itfin = "</em>" Else it = "": itfin = ""
        If cel.Characters(Start:=i, Length:=1).Font.FontStyle Like "*Gras*" Then b = "<b>": bfin = "</b>" Else b = "": bfin = ""
        If cel.Characters(Start:=i, Length:=1).Font.Underline = xlUnderlineStyleSingle Then soul = "<u>": soulfin = "</u>" Else soul = "": soulfin = ""
        texte = texte & it & b & soul & cel.Characters(Start:=i, Length:=1).Text & soulfin & bfin & itfin   'texte bon mais trop de balises inutile 
        texte = Replace(Replace(Replace(texte, "</u><u>", ""), "</em><em>", ""), "</b><b>", "")'texte netoyé
    Next
    cell_to_html = texte
End Function
'
Sub test()
    MsgBox cell_to_html(Cells(1, 1))
End Sub

demo


bourrin va
fit moi plaisir annalyse bien cette toute petite fonction tu y gagnera

[Areis]

bourrin va
fit moi plaisir annalyse bien cette toute petite fonction tu y gagnera

Hu hu hu... Promis je regarde ça demain, la longueur m'a bien plu en tout cas

[patricktoulon]

oh tu peux y aller les yeux fermés

[Areis]

il y a beaucoup beaucoup plus simple mais alors hypersimple
puique tu veux le faire dans des boucle avant et arriere je te propose une seule boucle et on va proceder comme les fonctions texte dans un wysiwyg(editeur html)
a savoir insert before mais la on va faire tout en string c'est a dire prendre la balise suivante et voir si c'est pas la meme que la precedente
mais pour cela chaque caracteres doit etre entre balise au depart

C'est carrément plus simple effectivement. Ce petit exercice m'aura permis d'avancer un peu dans mes maigres connaissances du VBA, merci Patrick.

[patricktoulon]

moi aussi tu vois j'aurais appris une chose
il y avait une petite coquille dans la la ligne "italique"
en effet quand un caracteres et gres et italique le font.style done "Gras italique" mais quand le caractere est seulement italique le font.style donne "Italique"

regarde bien le "i" de "italique" dans les deux modes
j'ai donc corrigé comme suit tout simplement

Code :

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

If LCase(cel.Characters(Start:=i, Length:=1).Font.FontStyle) Like "*italique*" Then it = "<em>": itfin = "</em>" Else it = "": itfin = ""

voila
je travaille sur la couleur aussi avec ce meme principe voir en tableau
en tout cas corrige cette ligne dans ton code si tu utilise mon code
a+

[patricktoulon]

re
pour le coup je me suis intéréssé a la couleur
voici un premier jet fonctionnelle tu a la conversion code hex en code html intégrée pour les couleurs

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
Sub test2()
    MsgBox cell_to_html2(Cells(1, 1))
End Sub
 
 Function cell_to_html2(cel As Range)
    Dim b, bfin, it, itfin, soul, soulfin, ftc, ftcfin, tablo(50)
    With cel
        a = 0
        For i = 1 To Len(.Text)
             'recuperation de la couleur au format hex et conversion au format HTML
            couleur = Right("000000" & Hex(.Characters(Start:=i, Length:=1).Font.Color), 6): coul = "#" & Right(couleur, 2) & Mid(couleur, 3, 2) & Left(couleur, 2)
            If .Characters(Start:=i, Length:=1).Font.Color Then a = a + 1: tablo(a) = CStr(coul): ftc = "<font color=" & coul & ">": ftcfin = "</font " & coul & ">" Else ftc = "": ftcfin = ""
            If LCase(.Characters(Start:=i, Length:=1).Font.FontStyle) Like "*italique*" Then it = "<em>": itfin = "</em>" Else it = "": itfin = ""
            If .Characters(Start:=i, Length:=1).Font.FontStyle Like "*Gras*" Then b = "<b>": bfin = "</b>" Else b = "": bfin = ""
            If .Characters(Start:=i, Length:=1).Font.Underline = xlUnderlineStyleSingle Then soul = "<u>": soulfin = "</u>" Else soul = "": soulfin = ""
            texte = texte & ftc & it & b & soul & .Characters(Start:=i, Length:=1).Text & soulfin & bfin & itfin & ftcfin   'texte bon mais trop de balises inutile
            texte = Replace(Replace(Replace(Replace(texte, "</u><u>", ""), "</em><em>", ""), "</b><b>", ""), ftcfin & ftc, "")    'texte netoyé
        Next
        For e = 1 To a - 1: texte = Replace(texte, "</font " & tablo(e), "</font"): Next
    End With
    cell_to_html2 = texte
End Function

tu devine aisement maintenant comment faire la meme chose pour les sizes

[BzhRico]

Merci patricktoulon,

Je cherchais un moyen de reporter le contenu formaté (Gras, italique, couleur, multi-ligne, ...) d'une cellule Excel dans un UserForm.
Puisque je n'ai pas trouvé le moyen de le faire dans une zone de texte ou Label, je me suis dit que la solution serait de passé par un WebBroser.

Et avec ton aide, et celle de dysorthographie ... J'ai réussi.

Voici mon code :

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
Private Sub CelToHTML(Cellule As Range, Controle As Control)
  ' Source : https://www.developpez.net/forums/d1798075/logiciels/microsoft-office/excel/macros-vba-excel/prise-compte-balises-html-gras-italique-souligne-mise-forme-cellules-inversement/
  Dim Transco As Variant, Contenu As Variant, Bcl As Integer
  Transco = Array("html:", "", "ss:", "", "<Data", "<pre  id =xx", "Data>", "pre>", "
", "<BR>")
  Contenu = Cellule.value(xlRangeValueXMLSpreadsheet)
  ' Convertir le xml en HTML
  For Bcl = 0 To UBound(Transco, 1) Step 2
    Contenu = Replace(Contenu, Transco(Bcl), Transco(Bcl + 1))
  Next
  With CreateObject("htmlfile")
    .Body.InnerHtml = Contenu
    Contenu = .getelementbyid("xx").InnerHtml
  End With
  ' source : https://www.developpez.net/forums/d1706004/logiciels/microsoft-office/access/vba-access/web-browser-html/
  zWebAide.Navigate "about:blank"
  Do
    DoEvents
  Loop While Controle.ReadyState <> 4 Or zWebAide.Busy
  Controle.Document.Body.InnerHtml = "<HTML><FONT SIZE=-1>" & Contenu & "</FONT></HTML>"
End Sub

PS : super tes exemples en images animées