RTF --> CODE HTML rtf, html, conversion, convertisseur, convert, Source N°1937

Information sur la source

Catégorie :Control Classé sous : rtf, html, conversion, convertisseur, convert Niveau : Débutant Date de création : 09/10/2001 Vu : 4 220

Auteur : Caïn

Site perso

Ecrire un message privé

Note :

10,00 / 10

1
2
3
4
5
6
7
8
9
10

Commentaire sur cette source (4)

Ajouter un commentaire et/ou une note

Description

Source

'##########################################################################################
'# Fonction retournant le code HTML du texte du contrôle rich text box passé en paramètre #
'##########################################################################################
' Paramètre(s) : vvRTBCtl -> contrôle RichTextBox contenant le texte à convertir
' Résultat(s) : convertRTFtoHTML -> Code HTML correspondant
Public Function convertRTFtoHTML(vvRTBCtl As Control) As String
Dim a
Dim IsBold As Boolean
Dim IsUnderline As Boolean
Dim IsItalic As Boolean
Dim vlStr As String
On Error Resume Next
IsItalic = False
IsUnderline = False
IsBold = False
vlStr = ""
For a = 0 To Len(vvRTBCtl.Text) + 2
vvRTBCtl.SelStart = a + 1
If vvRTBCtl.SelStart = Len(vvRTBCtl.Text) + 1 Then
IsBold = False
IsUnderline = False
IsItalic = False
End If
'Mettre en Gras
If vvRTBCtl.SelBold = True And IsBold = False Then
IsBold = True
vlStr = vlStr & ""
End If
If vvRTBCtl.SelBold = False And IsBold = True Then
IsBold = False
vlStr = vlStr & ""
End If
'Mettre en souligner
If vvRTBCtl.SelUnderline = True And IsUnderline = False Then
IsUnderline = True
vlStr = vlStr & ""
End If
If vvRTBCtl.SelUnderline = False And IsUnderline = True Then
IsUnderline = False
vlStr = vlStr & ""
End If
'Mettre en italic
If vvRTBCtl.SelItalic = True And IsItalic = False Then
IsItalic = True
vlStr = vlStr & ""
End If
If vvRTBCtl.SelItalic = False And IsItalic = True Then
IsItalic = False
vlStr = vlStr & ""
End If
If Asc(Mid(vvRTBCtl.Text, a + 1, 1)) = vbKeyReturn Then
vlStr = vlStr & " "
Else
vlStr = vlStr & Mid(vvRTBCtl.Text, a + 1, 1)
End If
If a = Len(vvRTBCtl.Text) - 1 Then
vlStr = vlStr & ""
vlStr = vlStr & ""
vlStr = vlStr & ""
End If
Next
convertRTFtoHTML = vlStr
End Function

'##########################################################################################
'# Fonction retournant le code HTML du texte du contrôle rich text box passé en paramètre #
'##########################################################################################
'   Paramètre(s) : vvRTBCtl         -> contrôle RichTextBox contenant le texte à convertir
'   Résultat(s)  : convertRTFtoHTML -> Code HTML correspondant
Public Function convertRTFtoHTML(vvRTBCtl As Control) As String
    Dim a
    Dim IsBold As Boolean
    Dim IsUnderline As Boolean
    Dim IsItalic As Boolean
    Dim vlStr As String
    
    On Error Resume Next
    
    IsItalic = False
    IsUnderline = False
    IsBold = False
    
    vlStr = ""
    
    For a = 0 To Len(vvRTBCtl.Text) + 2
        vvRTBCtl.SelStart = a + 1
        If vvRTBCtl.SelStart = Len(vvRTBCtl.Text) + 1 Then
            IsBold = False
            IsUnderline = False
            IsItalic = False
        End If

        'Mettre en Gras
        If vvRTBCtl.SelBold = True And IsBold = False Then
            IsBold = True
            vlStr = vlStr & "<B>"
        End If
        If vvRTBCtl.SelBold = False And IsBold = True Then
            IsBold = False
            vlStr = vlStr & "</B>"
        End If

        'Mettre en souligner
        If vvRTBCtl.SelUnderline = True And IsUnderline = False Then
            IsUnderline = True
            vlStr = vlStr & "<U>"
        End If
        If vvRTBCtl.SelUnderline = False And IsUnderline = True Then
            IsUnderline = False
            vlStr = vlStr & "</U>"
        End If

        'Mettre en italic
        If vvRTBCtl.SelItalic = True And IsItalic = False Then
            IsItalic = True
            vlStr = vlStr & "<I>"
        End If
        If vvRTBCtl.SelItalic = False And IsItalic = True Then
            IsItalic = False
            vlStr = vlStr & "</I>"
        End If

        If Asc(Mid(vvRTBCtl.Text, a + 1, 1)) = vbKeyReturn Then
            vlStr = vlStr & "<br>"
        Else
            vlStr = vlStr & Mid(vvRTBCtl.Text, a + 1, 1)
        End If

        If a = Len(vvRTBCtl.Text) - 1 Then
            vlStr = vlStr & "</I>"
            vlStr = vlStr & "</U>"
            vlStr = vlStr & "</B>"
        End If
    Next
    convertRTFtoHTML = vlStr
End Function

Conclusion

On peut facilement gérer les couleurs, l'alignement et la police de la même manière.

Sources de la même categorie

Toutes les sources de la catégorie Control

Sources en rapport avec celle ci

Commentaires

Commentaire de leptidev le 25/03/2002 13:00:10

Je comprends pas à quoi sert :

If a = Len(vvRTBCtl.Text) - 1 Then
 vlStr = vlStr & ""
 vlStr = vlStr & ""
 vlStr = vlStr & ""
 End If

Tu fermes tes ballises pour rien non ?!?!?!
Commentaire de yasr le 18/08/2003 17:19:05

Les liens ne fonctionnent pas!
Commentaire de tontonkika le 10/01/2005 13:46:44

si cela peut aider, une fonction intégrant l'alignement...

Public Function ConvertToHTML(Box As Control, Optional FlgAlert As Boolean = True, Optional b_netscape4 As Boolean = False) As String 'System.Windows.Forms.RichTextBox
 ' Converti une chaine RTF en HTML
 Dim strHTML As String
 Dim strColour As String
 Dim colorTmp As String
 Dim blnBold As Boolean
 Dim blnItalic As Boolean
 Dim blnUnderline As Boolean
 Dim strFont As String
 Dim shtSize As Single 'Short
 Dim strAlign As String
 Dim numAligne As Integer
 Dim lngOriginalStart As Long
 Dim lngOriginalLength As Long
 Dim intCount As Integer
 Dim s_diez As String

On Error GoTo ConvertToHTMLError

 ' On sort si la Box est vide
 If Len(Box.Text) = 0 Then
 Exit Function
 End If

 ' Stockage et recuperation du premier caractere
 lngOriginalStart = 0
 lngOriginalLength = Len(Box.Text)
 Box.SelStart = 0
 Box.SelLength = 1

 strHTML = ""

 ' Initialisation des parametres
 strColour = Right$("000000" & Hex(Box.SelColor), 6)
 strColour = Right$(strColour, 2) & Mid$(strColour, 3, 2) & Left$(strColour, 2)

' MsgBox Hex(strColour)
 blnBold = Box.SelBold
 blnItalic = Box.SelItalic
 blnUnderline = Box.SelUnderline

 strFont = Box.SelFontName
 shtSize = Box.SelFontSize
 numAligne = Box.SelAlignment
 Select Case Box.SelAlignment
 Case 0 ' Left
 strAlign = "Left"
 Case 1 ' right
 strAlign = "Right"
 Case 2 ' center
 strAlign = "Center"
 End Select


 ' ALIGN
 'If strAlign <> "" Then
 strHTML = strHTML & "<div align=""" & strAlign & """>"
 'End If

 ' STYLE
 If b_netscape4 Then
 strHTML = strHTML & ""
 Else
 s_diez = "#"

 strHTML = strHTML & ""
 End If

 ' Gestion du gras
 If blnBold Then
 strHTML = strHTML & ""
 End If
 ' Gestion de l'italique
 If blnItalic Then
 strHTML = strHTML & ""
 End If
 ' Gestion du souligné
 If blnUnderline Then
 strHTML = strHTML & ""
 End If

 ' premier caractere
 strHTML = strHTML & Box.SelText

 ' Pour tous les caracteres
 For intCount = 2 To Len(Box.Text)
 ' caractere courant
 Box.SelStart = (intCount - 1)
 Box.SelLength = 1

'MsgBox Box.SelText
 If Len(Box.SelText) > 0 And FlgAlert Then
 If Asc(Box.SelText) = 32 And FlgAlert Then
 If InStr(Box.SelRTF, "\pict\") > 0 Then
 If FlgAlert Then
 MsgBox "Attention, les images dans les textes, ne seront pas converties", vbCritical, "Attention"
 FlgAlert = False
 End If
 End If
 End If
 End If

 ' Gestion du saut de ligne
 If Box.SelText = Chr$(10) Or Len(Box.SelText) = 0 Then
 strHTML = strHTML & " "
 End If

 ' Changement de gras
 If Box.SelBold <> blnBold Then
 If Box.SelBold = False Then
 strHTML = strHTML & ""
 End If
 End If
 ' Changement d'italique
 If Box.SelItalic <> blnItalic Then
 If Box.SelItalic = False Then
 strHTML = strHTML & ""
 End If
 End If
 ' Changement de souligné
 If Box.SelUnderline <> blnUnderline Then
 If Box.SelUnderline = False Then
 strHTML = strHTML & ""
 End If
 End If

 ' Eventuel changement destyle
 colorTmp = Right$("000000" & Hex(Box.SelColor), 6)
 colorTmp = Right$(colorTmp, 2) & Mid$(colorTmp, 3, 2) & Left$(colorTmp, 2)
 If colorTmp <> strColour _
 Or Box.SelFontName <> strFont _
 Or Box.SelFontSize <> shtSize _
 Or Box.SelAlignment <> numAligne Then

 If b_netscape4 Then
 strHTML = strHTML & ""
 Else
 strHTML = strHTML & ""
 End If

 ' ALIGN
 If Box.SelAlignment <> numAligne Then
 Select Case Box.SelAlignment
 Case 0 ' Left
 strAlign = "Left"
 Case 1 ' right
 strAlign = "Right"
 Case 2 ' center
 strAlign = "Center"
 End Select
 strHTML = strHTML & "</div><div align=""" & strAlign & """>"
 End If

 If b_netscape4 Then
 'traitement de la taille du texte
 strHTML = strHTML & "<font family=""" & Box.SelFontName & _
 """ size=""" & Math.Round(Box.SelFontSize * 0.29, 0) & """ color=""" _
 & colorTmp & """>"
 Else
 s_diez = "#"

 strHTML = strHTML & "<span style=""font-family: " _
 & Box.SelFontName & _
 "; font-size: " & Box.SelFontSize & _
 "pt; color: " & s_diez & _
 colorTmp & """>"
 End If

 End If

 ' Changement de gras
 If Box.SelBold <> blnBold Then
 If Box.SelBold Then
 strHTML = strHTML & ""
 End If
 End If
 ' Changement d'italique
 If Box.SelItalic <> blnItalic Then
 If Box.SelItalic Then
 strHTML = strHTML & ""
 End If
 End If
 ' Changement de souligné
 If Box.SelUnderline <> blnUnderline Then
 If Box.SelUnderline Then
 strHTML = strHTML & ""
 End If
 End If

 ' Ajout du caractere
 If Len(Box.SelText) > 0 Then
 strHTML = strHTML & Mid$(Box.Text, intCount, 1)
 End If

 ' MAJ
 strColour = Right$("000000" & Hex(Box.SelColor), 6)
 strColour = Right$(strColour, 2) & Mid$(strColour, 3, 2) & Left$(strColour, 2)
 blnBold = Box.SelBold
 blnItalic = Box.SelItalic
 blnUnderline = Box.SelUnderline

 strFont = Box.SelFontName
 shtSize = Box.SelFontSize
 numAligne = Box.SelAlignment
 Select Case Box.SelAlignment
 Case 0 ' Left
 strAlign = "Left"
 Case 1 ' right
 strAlign = "Right"
 Case 2 ' center
 strAlign = "Center"
 End Select
 Next intCount

 ' Fermeture des tags bold/italic...
 If blnBold Then strHTML = strHTML & ""
 If blnItalic Then strHTML = strHTML & ""
 If blnUnderline Then strHTML = strHTML & ""

 ' On ferme le tag SPAN
 If b_netscape4 Then
 strHTML = strHTML & ""
 Else
 strHTML = strHTML & ""
 End If

 ' ALIGN
 'If strAlign <> "" Then
 strHTML = strHTML & "</div>"
 'End If

 ' Restauration de l'original richtextbox
 'Box.Select lngOriginalStart, lngOriginalLength

 ConvertToHTML = strHTML

Exit Function
ConvertToHTMLError:

 MsgBox Err.Description & vbCrLf & Err.Number, vbCritical, LoadResString(185 + Langage)
 Resume Next

End Function
Commentaire de l0st3d le 09/11/2005 09:58:45

Merci pour la source, c'est vraiment très utile

10/10

Ajouter un commentaire

Discussions en rapport avec ce code source

SVP Help me >Conversion rtf html par pekinio

Bilan => Conversion Rtf to HTML ! Propriétés Emplacement par scottmat

Conversion Excel -> HTML par Spag

Conversion Word -> HTML par Thermosam

Conversion RTF/TXT -> HTML par OneHacker

Conversion HTML vers PS par Didierdu92

conversion de pdf en html par kevinou55

conversion html en pdf par dahouetagnes

Imprimer un fichier (html. rtf..) en VB? par jeromax