Convertir le contenu d'un richtextbox en html

Télécharger le projet
Commenter

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.
Télécharger le projet

Codes Sources

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_Gael51)