Convertisseur rtf to html

Commenter

Contenu du snippet

Bonjour,

une petite fonction pour convertir du code RTF en HTML cette source n'est pas de moi mais je l'ai modifiée et corrigée. Je ne retrouve plus l'original alors je me permet de la republier..

Source / Exemple : 


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 txtTmp    As String
        Dim lienTmp   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
        Dim i               As Integer
        Dim Texte           As String
        Dim Charset         As String
        Dim CodeASCII       As String
        Dim CodePage        As String
        Dim LCID            As Long
        Dim X()             As Byte
        Dim Y()             As Byte
        
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 & "<font family=""" & strFont & _
            """ size=""" & Math.Round(shtSize * 0.29, 0) & """ color=""" _
              & Left(strColour, 6) & """>"
        Else
            s_diez = "#"

            strHTML = strHTML & "<span style=""font-family: " & strFont & _
                                        "; font-size: " & shtSize & "pt; color: " _
                                          & s_diez & Left$(strColour, 6) & """>"
        End If

        ' Gestion du gras
        If blnBold Then
            strHTML = strHTML & "<b>"
        End If
        ' Gestion de l'italique
        If blnItalic Then
            strHTML = strHTML & "<i>"
        End If
        ' Gestion du souligné
        If blnUnderline Then
            strHTML = strHTML & "<u>"
        End If

        ' premier caractere
        'strHTML = strHTML & Box.SelText

        ' Pour tous les caracteres
        intCount = 0
        Do While intCount <= Len(Box.Text)
            intCount = intCount + 1
        'For intCount = 1 To Len(Box.Text)
            ' caractere courant
            Box.SelStart = (intCount - 1)
            Box.SelLength = 1
            
'MsgBox Box.SelText & vbCrLf & vbCrLf & Box.SelRTF
            
            If Len(Box.SelText) > 0 Then
                If 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
            End If
            
            ' Gestion du saut de ligne
            If Box.SelText = Chr$(10) Or Len(Box.SelText) = 0 Then
                strHTML = strHTML & "<br>"
                intCount = intCount + 1
            End If

            ' Changement de souligné
            If Box.SelUnderline <> blnUnderline Then
                If Box.SelUnderline = False Then
                    strHTML = strHTML & "</u>"
                End If
            End If
            ' Changement d'italique
            If Box.SelItalic <> blnItalic Then
                If Box.SelItalic = False Then
                    strHTML = strHTML & "</i>"
                End If
            End If
            ' Changement de gras
            If Box.SelBold <> blnBold Then
                If Box.SelBold = False Then
                    strHTML = strHTML & "</b>"
                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 & "</font>"
                Else
                    If blnBold And Box.SelBold Then
                        strHTML = strHTML & "</b>"
                        blnBold = False
                    End If
                    If blnItalic And Box.SelItalic Then
                        strHTML = strHTML & "</i>"
                        blnItalic = False
                    End If
                    If blnUnderline And Box.SelUnderline Then
                        strHTML = strHTML & "</u>"
                        blnUnderline = False
                    End If
                    strHTML = strHTML & "</span>"
                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 & "<b>"
                End If
            End If
            ' Changement d'italique
            If Box.SelItalic <> blnItalic Then
                If Box.SelItalic Then
                    strHTML = strHTML & "<i>"
                End If
            End If
            ' Changement de souligné
            If Box.SelUnderline <> blnUnderline Then
                If Box.SelUnderline Then
                    strHTML = strHTML & "<u>"
                End If
            End If

            
            If Len(Box.SelText) > 0 Then
                ' test si lien
                '<a href="http://www.perspective123.com">lien</a>
                If InStr(Box.SelRTF, "\ul\") > 0 And InStr(intCount + 1, Box.Text, ">") > 0 And InStr(intCount + 1, Box.Text, ">") < InStr(intCount + 1, Box.TextRTF, "\ulnone") Then
                    For i = intCount To InStr(intCount + 1, Box.Text, ">")
                        Box.SelStart = (i - 1)
                        Box.SelLength = 1
                        If InStr(Box.SelRTF, "\ul\") <= 0 Then
                            Exit For
                        End If
                    Next i
                    Box.SelStart = (intCount - 1)
                    Box.SelLength = 1
                        
                    If i = InStr(intCount + 1, Box.Text, ">") + 1 Then
                        lienTmp = Mid$(Box.Text, intCount, InStr(intCount + 1, Box.Text, ">") - intCount)
                        lienTmp = Mid$(lienTmp, InStr(lienTmp, "<") + 1)
'                        MsgBox Mid$(Box.Text, intCount, InStr(intCount + 1, Box.Text, "<") - intCount)
                        
                        strHTML = strHTML & "<a href=""" & lienTmp & """ target=""_blank"">" & Mid$(Box.Text, intCount, InStr(intCount + 1, Box.Text, "<") - intCount) & "</a>"
                        intCount = InStr(intCount + 1, Box.Text, ">")
                    End If
                    
                    
                ElseIf Box.SelText = "?" And InStr(Box.SelRTF, " ?}") = 0 Then
                    'If InStr(Box.SelRTF, " ?}") = 0 Then
                    MsgBox "caractère étranger : " & vbCrLf & Box.SelRTF
                    Charset = Mid$(Box.SelRTF, InStr(Box.SelRTF, "\fcharset") + 9)
                    Charset = Left$(Charset, InStr(Charset, " ") - 1)
                    If InStr(Box.SelRTF, "\'") > 0 Then
                        CodeASCII = Mid$(Box.SelRTF, InStr(Box.SelRTF, "\'") + 2)
                        CodeASCII = Left$(CodeASCII, InStr(CodeASCII, "}") - 1)
                        CodeASCII = "&h0" & Replace(CodeASCII, "\'", "&h0")
                        'MsgBox "" & Chr$(Val(Right$(CodeASCII, 5)))
                        'MsgBox "" & StrConv(Chr$(Val(Left$(CodeASCII, 5))) & Chr$(Val(Right$(CodeASCII, 5))), vbUnicode, 2052)
                        Select Case Charset
                            Case 0   ' Ansi
                                LCID = 0
                            Case 1   ' Default
                                LCID = 0
                            Case 2   ' Symbol
                                LCID = 0
                            Case 3   ' Invalid
                                LCID = 0
                            Case 77  ' Mac
                                LCID = 0
                            Case 128 ' Shift Jis
                                LCID = 0
                                CodePage = 932
                            Case 129 ' Hangul
                                LCID = 0
                            Case 130 ' Johab
                                LCID = 0
                            Case 134 ' GB2312
                                LCID = 2052
                                CodePage = 936
                            Case 136 ' Big5
                                LCID = 1028
                                CodePage = 950
                            Case 161 ' Greek
                                LCID = 0
                                CodePage = 1253
                            Case 162 ' Turkish
                                LCID = 0
                                CodePage = 1254
                            Case 163 ' Vietnamese
                                LCID = 0
                                CodePage = 1258
                            Case 177 ' Hebrew
                                LCID = 0
                            Case 178 ' Arabic
                                LCID = 0
                                CodePage = 1256
                            Case 179 ' Arabic Traditional
                                LCID = 0
                            Case 180 ' Arabic user
                                LCID = 0
                            Case 181 ' Hebrew user
                                LCID = 0
                            Case 186 ' Baltic
                                LCID = 0
                            Case 204 ' Russian
                                LCID = 0
                            Case 222 ' Thai
                                LCID = 0
                                CodePage = 874
                            Case 238 ' Eastern European
                                LCID = 0
                            Case 254 ' PC 437
                                LCID = 0
                            Case 255 ' OEM
                                LCID = 0
                            Case Else
                                MsgBox "Attention la langue utilisée dans le texte n'est pas supportée : Charset=" & CStr(Charset)
                                LCID = 0
                        End Select
                        
                        ReDim X(1)
                        X(0) = Val(Left$(CodeASCII, 5))
                        X(1) = Val(Right$(CodeASCII, 5))
                        Y = StrConv(X, vbUnicode, LCID)   ' Convert string.
                        CodeASCII = "&h0" & Hex$(Y(1)) & Hex$(Y(0))
                    Else
                        CodeASCII = Mid$(Box.SelRTF, InStr(Box.SelRTF, "?}") - 5, 5)
                    End If
                    
                    strHTML = strHTML & "&#" & CStr(Val(CodeASCII)) & ";"
                    intCount = intCount + 1
                    
                Else ' Ajout du caractere
                    txtTmp = Box.SelText  'Mid$(Box.Text, intCount, 1)
'                    MsgBox "" & Asc(Mid$(Box.Text, intCount, 1))
                    Select Case txtTmp
                        Case "<"
                            strHTML = strHTML & "<"
                        Case Chr$(13), Chr$(10)
                            strHTML = strHTML & ""
                        Case " "
                            If Right$(strHTML, 1) = " " Then
                                strHTML = Left$(strHTML, Len(strHTML) - 1) & "&nbsp;&nbsp;"
                            ElseIf Right$(strHTML, 6) = "&nbsp;" Or Box.SelStart < 1 Then
                                strHTML = strHTML & "&nbsp;"
                            Else
                                strHTML = strHTML & " "
                            End If
                        Case Else
                            strHTML = strHTML & txtTmp
                    End Select
                        
                End If
                '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
        Loop
        'Next intCount
        
        ' Fermeture des tags bold/italic...
        If blnBold Then strHTML = strHTML & "</b>"
        If blnItalic Then strHTML = strHTML & "</i>"
        If blnUnderline Then strHTML = strHTML & "</u>"

        ' On ferme le tag SPAN
        If b_netscape4 Then
            strHTML = strHTML & "</font>"
        Else
            strHTML = strHTML & "</span>"
        End If

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

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

        ' Gestion des liens HTML du type
        ' $£$http://www.yahoo.fr$£$cliquez ici$£$
        Do While InStr(strHTML, "$£$") > 0
            i = InStr(strHTML, "$£$")
            If InStr(i + 1, strHTML, "$£$") > 0 Then
                'cherche la troisième balise
                If InStr(InStr(i + 1, strHTML, "$£$"), strHTML, "$£$") > 0 Then
                    Texte = Mid$(strHTML, i + 3)
                    Texte = Left$(Texte, InStr(Texte, "$£$") - 1) & "' target='_blank'>" & Mid$(Texte, InStr(Texte, "$£$") + 3)
                    strHTML = Left$(strHTML, i - 1) & "<a href='" & Texte
                    i = InStr(strHTML, "$£$")
                    strHTML = Left$(strHTML, i - 1) & "</a>" & Mid(strHTML, i + 3)
                End If
            End If
        Loop

        ConvertToHTML = strHTML

Exit Function
ConvertToHTMLError:

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

Conclusion :


La source est commentée,
Box est le controle textRTF de microsoft...

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.