Convertir le contenu d'un richtextbox en html

Soyez le premier à donner votre avis sur cette source.

Vue 12 167 fois - Téléchargée 978 fois

Description

Le code contient une fonction qui transforme le contenu d'un RichTextBox en code HTML.
(encore!!) >> peut-être, mais j'ai pas vu d'autre code qui prenait en compte :
Gras,Italique, Souligner, aligner à gauche/centre/droite/justifier, puce, retrait avant/arrière, espaces insécables(multiples), retour à la ligne, couleur de police, nom de police, taille de police, paragraphe.

ex:RTBtest as RichtextBox, text1 as TextBox, justify as boolean
>> justify permet de dire si les paragraphes aligner à gauche sont justifier ou pas

Appel de la function : text1.text = RTBtoHTM (RTBtest,True)

C'est mon premier code, soyez indulgent, il peut surement être beaucoup améliorer...

Source / Exemple :


'RTBtoHTM > Convertit le contenu d'une RichTextBox en HTML
'ex:RTBtest as RichtextBox, text1 as TextBox, justify as boolean
' >> justify permet de dire si les paragraphes aligner à gauche sont justifier ou pas
'Appel de la function : text1.text = RTBtoHTM (RTBtest,True)
'
'la function prend en charge les paramètres suivant :
'Gras,Italique, Souligner, aligner à gauche/centre/droite/justifier,
'puce, retrait avant/arrière, espaces insécables(multiples), retour à la ligne,
'couleur de police, nom de police, taille de police, paragraphe.
'
'Attention : la fonction créer uniquement le code pour le texte en s'appuyant
' sur les paramètres de police par défaut du RichTextBox contenant le texte à modifier
'
'ligne à ajouter avant RTBtoHTM (ex.): <body style="font-family: Arial; font-size: 10 pt">
'ligne à ajouter après RTBtoHTM : </body>
'
Public Function RTBtoHTM(RtbConvertHtm As RichTextBox, Alignement As Boolean) As String
    Dim memDeb As Long  'mémoire de la position de départ de la selection
    Dim memLong As Long 'mémoire de la taille de la selection
    Dim ch As String 'caractère selectionner à convertir en HTML
    Dim chProvis As String  'chaine à insérer à la fin d'un paragraphe
    Dim Txtparagraphe As String 'chaine à insérer en début de paragraphe
    Dim Fname As String     'chaine contenant le nom de police par défaut
    Dim Fcolor As Long       'valeur contenant la couleur de texte par défaut
    Dim Fsize As Single     'valeur contenant la taille de texte par défaut
    Dim Ffont As String     'texte contenant le paramètre modifier de la police
    Dim memFont As String   'mémoire des parametre de police
    Dim retour As Boolean   'méoire pour controler les lignes sans caractère
    Dim espace As Boolean   'mémoire pour controler les espaces insécables
    Dim Gras As Boolean     'mémoire pour controler le changement de mise en forme
    Dim Italiq As Boolean   'mémoire pour controler le changement de mise en forme
    Dim Soulign As Boolean  'mémoire pour controler le changement de mise en forme
    Dim Puce As Boolean     'mémoire pour controler le changement de mise en forme
    Dim memRetrait As Integer   'mémoire pour controler la taille des retraits
    
    'mise en mémoire de la sélection
    memDeb = RtbConvertHtm.SelStart
    memLong = RtbConvertHtm.SelLength
    
    'initialisation des paramètres
    RtbConvertHtm.SelStart = 0
    RtbConvertHtm.SelLength = 1
    
    retour = True
    espace = False
    Gras = False
    Italiq = False
    Soulign = False
    Police = False
    Fname = RtbConvertHtm.Font.Name
    Fsize = RtbConvertHtm.Font.Size
    Fcolor = 0
    memFont = ""
    Retrait = False
    memRetrait = 0
    Puce = False
    
    'début du test des caractères du RichtextBox
    GoSub BoucleParagraphe
    RTBtoHTM = Txtparagraphe
    For i = 0 To Len(RtbConvertHtm.Text)
        RtbConvertHtm.SelStart = i
        RtbConvertHtm.SelLength = 1
        
        'si renvoi à la ligne
        If RtbConvertHtm.SelText = "" Then
            
            'si le paragraphe ne contient pas de caractère
            If retour Then
                'teste si on est à la fin du texte
                If i = Len(RtbConvertHtm.Text) And RtbConvertHtm.SelLength = 0 Then GoTo FinText
                RTBtoHTM = RTBtoHTM & "<BR>" & vbCrLf
            Else
                'a la fin du paragraphe, on ferme les balises htm
                chProvis = ""
                If Gras Then chProvis = "</B>" & chProvis
                If Italiq Then chProvis = "</I>" & chProvis
                If Soulign Then chProvis = "</U>" & chProvis
                If memFont <> "" Then chProvis = chProvis & "</FONT>": memFont = ""
                
                If RtbConvertHtm.SelBullet Then chProvis = chProvis & "</li>"
                'puis on ferme le paragraphe
                RTBtoHTM = RTBtoHTM & chProvis & "</p>" & vbCrLf
            End If
            
            'test l'alignement du texte qui suit le paragraphe actif
            If i < Len(RtbConvertHtm.Text) Then
                RtbConvertHtm.SelStart = i + 2
                RtbConvertHtm.SelLength = 1
                GoSub BoucleParagraphe
                RTBtoHTM = RTBtoHTM & Txtparagraphe
            End If
            retour = True
            i = i + 1
        Else
            If retour Then retour = False
            'teste les caractères non compatible html
            ch = TestHtm(RtbConvertHtm.SelText)
            If ch = " " Then
                If espace Then ch = "&nbsp;"
                espace = True
            Else
                espace = False
            End If
            
            'teste quand le texte devient gras ou devient normal
            If RtbConvertHtm.SelBold And Not Gras Then ch = "<B>" & ch: Gras = True
            If Not RtbConvertHtm.SelBold And Gras Then ch = "</B>" & ch: Gras = False
            
            'teste quand le texte devient gras ou devient normal
            If RtbConvertHtm.SelItalic And Not Italiq Then ch = "<I>" & ch: Italiq = True
            If Not RtbConvertHtm.SelItalic And Italiq Then ch = "</I>" & ch: Italiq = False
            
            'teste quand le texte devient gras ou devient normal
            If RtbConvertHtm.SelUnderline And Not Soulign Then ch = "<U>" & ch: Soulign = True
            If Not RtbConvertHtm.SelUnderline And Soulign Then ch = "</U>" & ch: Soulign = False
            
            'défini le paramètre de <FONT ...> qui change
            Ffont = ""
            If RtbConvertHtm.SelFontName <> Fname Then Ffont = " face=" & Chr$(34) & RtbConvertHtm.SelFontName & Chr$(34)
            If RtbConvertHtm.SelFontSize <> Fsize Then Ffont = Ffont & " size=" & Chr$(34) & FontSizeHtm(RtbConvertHtm.SelFontSize) & Chr$(34)
            If RtbConvertHtm.SelColor <> Fcolor Then Ffont = Ffont & " color=" & Chr$(34) & ColorHtm(RtbConvertHtm.SelColor) & Chr$(34)
            
            If Ffont <> memFont Then
                If memFont = "" Then
                    ch = "<FONT " & Ffont & " > " & ch
                Else
                    If Ffont = "" Then
                        ch = "</FONT>" & ch
                    Else
                        ch = "</FONT><FONT " & Ffont & " >" & ch
                    End If
                End If
            End If
            memFont = Ffont
                       
            RTBtoHTM = RTBtoHTM + ch
        End If
        
    Next i

FinText:
    RtbConvertHtm.SelStart = memDeb
    RtbConvertHtm.SelLength = memLong

    Exit Function

BoucleParagraphe:
    
    If RtbConvertHtm.SelLength = 0 Then
        Txtparagraphe = ""
    Else
        If RtbConvertHtm.SelAlignment = 0 And Not Alignement Then Txtparagraphe = "<p style=" & Chr$(34) & "margin-top: 0; margin-bottom: 0" & Chr$(34) & ">" & vbCrLf
        If RtbConvertHtm.SelAlignment = 0 And Alignement Then Txtparagraphe = "<p" & " align=" & Chr$(34) & "Justify" & Chr$(34) & " style=" & Chr$(34) & "margin-top: 0; margin-bottom: 0" & Chr$(34) & ">" & vbCrLf
        If RtbConvertHtm.SelAlignment = 1 Then Txtparagraphe = "<p" & " align=" & Chr$(34) & "Right" & Chr$(34) & " style=" & Chr$(34) & "margin-top: 0; margin-bottom: 0" & Chr$(34) & ">" & vbCrLf
        If RtbConvertHtm.SelAlignment = 2 Then Txtparagraphe = "<p" & " align=" & Chr$(34) & "Center" & Chr$(34) & " style=" & Chr$(34) & "margin-top: 0; margin-bottom: 0" & Chr$(34) & ">" & vbCrLf
    End If
    
    'défini les lignes à puces
    If RtbConvertHtm.SelBullet Then Txtparagraphe = "<li>" & Txtparagraphe
    If RtbConvertHtm.SelBullet And Not Puce Then Txtparagraphe = "<ul>" & vbCrLf & Txtparagraphe: Puce = True
    If Not RtbConvertHtm.SelBullet And Puce Then Txtparagraphe = "</ul>" & vbCrLf & Txtparagraphe: Puce = False
    
    'défini si il y a un retrait en plus ou en moins dans le paragraphe
    If Round(RtbConvertHtm.SelIndent, 0) > memRetrait Then
        For j = memRetrait To RtbConvertHtm.SelIndent Step 500
            Txtparagraphe = "<blockquote>" & vbCrLf & Txtparagraphe
        Next j
    End If
    If Round(RtbConvertHtm.SelIndent, 0) < memRetrait Then
        For j = RtbConvertHtm.SelIndent To memRetrait Step 500
            Txtparagraphe = "</blockquote>" & vbCrLf & Txtparagraphe
        Next j
    End If
    memRetrait = RtbConvertHtm.SelIndent
Return
    
End Function

'TestHtm transforme les caractères spéciaux en code HTML
Public Function TestHtm(ch As String) As String
    If ch = "<" Or ch = ">" Or ch = "&" Or ch = Chr$(34) Or Asc(ch) > 160 Then
        TestHtm = "&#" & Trim$(Str$(Asc(ch))) & ";"
    Else
        TestHtm = ch
    End If
End Function

'ColorHtm retourne une chaine correspondant à la couleur entrée en paramètre
' exemple pour rouge(RGB(255,0,0) >> "#FF0000"
Public Function ColorHtm(Couleur As Long) As String
    Dim rouge As Integer
    Dim vert As Integer
    Dim bleu As Integer
    
    rouge = Couleur - (256 * Int((Couleur - (Int(Couleur / 65536) * 65536)) / 256) + (65536 * Int(Couleur / 65536)))
    vert = Int((Couleur - (Int(Couleur / 65536) * 65536)) / 256)
    bleu = Int(Couleur / 65536)
    
    ColorHtm = "#" & Right$("0" & Hex$(rouge), 2) & Right$("0" & Hex$(vert), 2) & Right$("0" & Hex$(bleu), 2)
    
End Function

'FontSizeHtm retourne le code des taille valide en HTML
Function FontSizeHtm(taille As Single) As String
    If taille <= 9 Then FontSizeHtm = "1"
    If taille > 9 And taille <= 11 Then FontSizeHtm = "2"
    If taille > 11 And taille <= 13 Then FontSizeHtm = "3"
    If taille > 13 And taille <= 16 Then FontSizeHtm = "4"
    If taille > 16 And taille <= 21 Then FontSizeHtm = "5"
    If taille > 21 And taille <= 30 Then FontSizeHtm = "6"
    If taille > 30 Then FontSizeHtm = "7"
End Function

Conclusion :


Attention : la fonction créer uniquement le code pour le texte en s'appuyant sur les paramètres de police par défaut du RichTextBox contenant le texte à modifier

la fonction ne créer pas une page html complète

Je pense que vous devriez y jeter un ptit coup d'oeil.

Codes Sources

A voir également

Ajouter un commentaire Commentaires
Messages postés
8
Date d'inscription
lundi 29 décembre 2003
Statut
Membre
Dernière intervention
2 août 2007

Un lien qui m'a bien aidé pour convertir cette source en VB 2005 :
(tableau comparatif des paramètres du richtexbox entre VB6 et 2005)
http://msdn2.microsoft.com/en-us/library/ms234980(vs.80).aspx

Très bonne source, bravo.
Faudrait juste éviter les goto et les gosub. Crée des procédure ou des fonctions pour tes routines...
Messages postés
24
Date d'inscription
jeudi 27 avril 2006
Statut
Membre
Dernière intervention
23 juin 2007
1
Et bien je suis tomber sur ta source par hazard j'ai commencer a lire et puis j'ai télécharger pour faire un test.

Résultat rien a dire même une personne qui n'a jamais programer en HTML peut le faire.

Bravo 10/10
Messages postés
170
Date d'inscription
jeudi 11 décembre 2003
Statut
Membre
Dernière intervention
24 janvier 2009

Sans parler de l'intérêt de la source (tout à fait valable), c'est agréable de lire pour une fois du code clairement organisé, structuré, commenté. Cerise sur le gateau: les commentaires et explications sont rédigés dans un excellent français. Un exemple à suivre!

Gaël, je ne sais pas si tu connais MZTools, c'est un Addin pour VB, très pratique pour plein de choses et notamment pour faciliter l'écriture systématique d'entêtes de fonctions et modules. C'est un logiciel gratuit disponible ici: http://www.mztools.com/
Messages postés
6
Date d'inscription
mardi 17 décembre 2002
Statut
Membre
Dernière intervention
13 avril 2009

Merci pour l'info (jean_marc_n2), je savais pas. G donc fais la modif.
Pour le lien de "nofutur", ça à l'air cool, mais bigrement compliqué, et pis chez moi, il manque certains éléments pour pouvoir le tester...

@+
Messages postés
171
Date d'inscription
mardi 17 décembre 2002
Statut
Membre
Dernière intervention
6 mai 2007

Super la source 8/10,

Moi j'avais trouvé il y a longtemps un module similaire que je n'ai jamais eu le temps de tester mais qui reste très complet. Peut être que sa structure te donnera des idées pour améliorer ta source :-)

http://www2.bitstream.net/~bradyh/downloads/rtf2htmlrm.html

Bonne prog ^_^
@plus!
Afficher les 10 commentaires

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.