|
 Trouver une ressource
Vous ne trouvez pas de réponse à votre problème ? Alors posez la question dans le forum. Souvenez-vous qu'il n'y a jamais de question bête, mais rester dans l'ignorance parce que l'on n'ose pas poser une question, ça c'est une erreur !
 CONVERTISSEUR RTF TO HTML
 Information sur la source
 Description
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
- 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) & " "
- ElseIf Right$(strHTML, 6) = " " Or Box.SelStart < 1 Then
- strHTML = strHTML & " "
- 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
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) & " "
ElseIf Right$(strHTML, 6) = " " Or Box.SelStart < 1 Then
strHTML = strHTML & " "
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...
 Sources de la même categorie
Sources en rapport avec celle ci
 Commentaires et avis
 Discussions en rapport avec ce code source dans le forum
SVP Help me >Conversion rtf html [ par pekinio ]
hello a tlmvoila, en fait, je voudrais enregistrer le contenu d'une rtf box , avec caracteres en couleurs, eventuellement des photos et tout, en html.
Convertisseur rtf?? [ par comtention ]
Bonjour,J'aimerais bien savoir si il existe un programme qui, apres avoir écris un texte dans celui-ci (avec des couleurs, des passages en gras e
Imprimer un fichier (html. rtf..) en VB? [ par jeromax ]
Tout est dit dans le sujetMerci
Bilan => Conversion Rtf to HTML ! Propriétés Emplacement [ par scottmat ]
<span style="FONT-SIZE: 12pt; COLOR: #4f81bd; LINE-HEIGHT: 115%; FONT-FAMILY: 'Verdana','sans-serif'; mso-themec
Conversion RTF/TXT -> HTML [ par OneHacker ]
Je programme avec VS Express 2005 .NET. Je voulais savoir s'il était possible de convertir du texte simple HTML ou du RTF en HTML.J'ai essayé ça mais
Rtf to Html via Word automation [ par pattex62 ]
Rtf to Html via Word automation Bonjour à tous !!! Je souhaiterais convertir le contenu d'un Richtexbox (format RTF) en format HTML !!! </p
Clipboard et Copier-Coller dans outlook [ par Enibble ]
Bonjour à tous,Voici plusieurs jours que je galère sur le copier-coller d'un texte au format RTF.Je m'explique.Je crée un nouveau rendez-vous (Appoint
Convertisseur VB6 à C# [ par sghchafaa ]
Bonjour;Est ce qu'il y a quelqu'un qui peut me proposer une application qui converte un source de VB6 (pas celui .NET mais plutot VB6) vers le csharp
|
 Téléchargements
Logiciels à télécharger sur le même thème :
|