Soyez le premier à donner votre avis sur cette source.
Snippet vu 6 800 fois - Téléchargée 17 fois
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
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.