Soyez le premier à donner votre avis sur cette source.
Vue 12 610 fois - Téléchargée 1 006 fois
'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 = " " 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
2 août 2007 à 11:01
(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...
20 juil. 2007 à 11:26
Résultat rien a dire même une personne qui n'a jamais programer en HTML peut le faire.
Bravo 10/10
28 mars 2006 à 20:43
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/
28 mars 2006 à 19:34
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...
@+
28 mars 2006 à 18:17
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!
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.