1. Accueil
  2. Tous les snippets
  3. Snippets Visual Basic / VB.NET
  4. Formatage d'une cellule excel via une syntaxe html

Formatage d'une cellule excel via une syntaxe html

Soyez le premier à donner votre avis sur cette source.

Snippet vu 6 800 fois - Téléchargée 17 fois

Commenter

Contenu du snippet

Cette fonction permet de mettre en forme le contenu d'une cellule par l'entremise d'une syntaxe HTML.
Pour le moment, seule "<u>" (souligné), "<b>" (gras) et "<i>" (italique) et <Texte bleu> (couleur bleu) ont été implémentés.

Pré-requis : La bibliothèque "Microsoft VBScript Regular Expression 5.5" (%windir%\System32\vbscript.dll)

Pour mettre en place une nouvelle balise :

- Redimensionner le tableau ligne 2
- Renseigner la nouvelle balise ligne 19
- Désactiver la mise en forme correspondante dans la cellule Excel à partir de la ligne 14
- Renseigner le SELECT CASE ligne 88

Source / Exemple : 


Public Sub HTML2XLS(Rang As Range)
Dim Balise(3) As String, Save_Rang As String, Morceau_Motif(1) As String, a As Integer, Taille As Integer
Dim Regle(1) As New RegExp, Results As MatchCollection, Result As Match, Temp(1) As String
Dim Style As String, EntreBalises As String, PosDsRang As Integer

'Le fait de faire des Replace sur une cellule supprime les mises en forme précédentes
'C'est pour cela qu'on récupère tous les résultats avant de supprimmer les balises et d'appliquer les mises en formes

With Rang
    'On désactive les mises en forme correspondant aux balises
    .Font.Bold = False
    .Font.Underline = xlUnderlineStyleNone
    .Font.Italic = False
    .Font.ColorIndex = 0
End With

Save_Rang = Rang

Balise(0) = "b": Balise(1) = "u": Balise(2) = "i": Balise(3) = "Texte bleu"
Taille = UBound(Balise)

'On supprime toutes les balises de Rang
For a = 0 To Taille
    Rang = Replace(Rang, "<" & Balise(a) & ">", "")
    Rang = Replace(Rang, "</" & Balise(a) & ">", "")
Next a

'On élabore la partie du motif correspondant aux balises entrantes
Morceau_Motif(0) = "<(("
For a = 0 To Taille
    Morceau_Motif(0) = Morceau_Motif(0) & Balise(a) & ")|("
Next a
Morceau_Motif(0) = Left(Morceau_Motif(0), Len(Morceau_Motif(0)) - 2) 'On enlève le dernier "|("
Morceau_Motif(0) = Morceau_Motif(0) & ")>"
Morceau_Motif(1) = Replace(Morceau_Motif(0), "<", "</?")
'On récupère tout ce qui doit être formaté dans l'odre de succession dans la chaine ainsi que les balises de formatage
With Regle(0)
    'On construit le motif
    .Pattern = Morceau_Motif(0) & "(.+)</\1>"
    'Pour info le motif est "<((b)|(u)|(i)|(Texte bleu))>(.+)</\1>"
    .IgnoreCase = True
    .MultiLine = True
    
    'Tant que l'on a des balises
    While .Test(Save_Rang)
        Set Results = .Execute(Save_Rang)
        'Pour le résultat trouvé:
        '- On regarde quelle est la chaine contenue dans une balise et quelle est son style
        '- On récupère toutes la partie allant de cette occurrence jusqu'à la fin de la chaine de caractères
        'et on y enlève toutes les balises, ainsi que celles présentes dans EntreBalises
        '- Pour chaque occurrence EntreBalises présente dans Rang, on regarde si la chaine de caractères allant
        'de cette dernière jusqu'à la fin de la chaine est égale à celle dont on a enlevé les balises dans Save_Rang
        '- Si c'est le cas, on applique le style
        'On supprime de SaveRang les balises qui viennent d'être traitées
        
        With Results(0)
            If .SubMatches(0) <> vbNullString Then
                Taille = .SubMatches.Count - 1
                Style = .SubMatches(0)
                EntreBalises = .SubMatches(Taille)
                
                'Il est possible que la balise soit utilisée plusieurs fois et que la balise de fermeture d'une autre partie de la chaine soit
                'celle correspondant à la balise d'ouverture
                'Exemple : <u>Florent Bénetière</u>, c'est <u><i><b><Texte bleu> <--Florent Bénetière--></Texte bleu></b></i></u>
                '=> On recherche la balise de fermeture la plus proche de celle d'ouverture
                                
                If InStr(1, EntreBalises, "</" & Style & ">") - 1 > 0 Then EntreBalises = Mid(EntreBalises, 1, InStr(1, EntreBalises, "</" & Style & ">") - 1)
                                
                Temp(0) = Mid(Save_Rang, InStr(1, Save_Rang, "<" & Style & ">" & EntreBalises & "</" & Style & ">"))
                Temp(1) = EntreBalises
                
                With Regle(1)
                    .Global = True
                    .IgnoreCase = True
                    .MultiLine = True
                    .Pattern = Morceau_Motif(1)
                    Temp(0) = .Replace(Temp(0), vbNullString)
                    Temp(1) = .Replace(EntreBalises, vbNullString)
                End With
                
                PosDsRang = 1
                
                Do Until PosDsRang = 0
                    PosDsRang = InStr(PosDsRang, Rang, Temp(1))
                    
                    If Mid(Rang, PosDsRang) = Temp(0) Then
                        With Rang
                            Select Case Style
                                Case "b"
                                    .Characters(Start:=PosDsRang, Length:=Len(Temp(1))).Font.Bold = True
                                Case "u"
                                    .Characters(Start:=PosDsRang, Length:=Len(Temp(1))).Font.Underline = xlUnderlineStyleSingle
                                Case "i"
                                    .Characters(Start:=PosDsRang, Length:=Len(Temp(1))).Font.Italic = True
                                Case "Texte bleu"
                                    .Characters(Start:=PosDsRang, Length:=Len(Temp(1))).Font.ColorIndex = 11
                            End Select
                        End With
                        
                        Save_Rang = Replace(Save_Rang, "<" & Style & ">" & EntreBalises & "</" & Style & ">", EntreBalises, , 1)
                        
                        Exit Do
                    End If
                    PosDsRang = PosDsRang + 1
                Loop
                
            End If
        End With
        DoEvents
    Wend
End With
End Sub

Conclusion :


Exemple d'utilisation
Private Sub Worksheet_Activate()
Range("A1") = "<u>Florent Bénetière</u>, c'est <u><</>>/<</><i><b><Texte bleu><--Florent Bénetière--></Texte bleu></b></i></u> je te dis." & vbCrLf & vbCrLf & "<u>Florent Bénetière</u>"
HTML2XLS Range("A1")
End Sub

Pour celles et ceux qui voudraient avoir à peu près la même chose avec le corps des mémos Lotus Notes, je vous invite à aller voir mon "Générateur de mail Lotus Notes avec mise en forme via une syntaxe HTML"

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (cs_8Tnerolf8)