[x]
Posted via EE Mobile

Search, ask, and monitor your questions on the go with EE Mobile. Visit Experts Exchange from your mobile device and never be out of touch again.
04/21/2009 at 05:30PM PDT, ID: 24343606
[x]
Attachment Details
[x]
The Solution Rating System

With so many solutions, how can you tell which solutions are most likely to help you and which ones are not? To provide you with a tool to use, we rate our solutions based on various elements that most accurately determine if a solution is a quality solution. To explain what factors affect the solution rating, here are the elements we take into consideration when formulating our solution rating.

  • The Grade of the Solution
  • The Zone Rank of the Expert Providing the Solution
  • The Number of Author and Expert Comments
  • The Number of Experts Contributing
  • The Feedback of the Community

Your Input Matters
Because of the way the system is set up, the most important variable in this equation is you. As a member of Experts Exchange, you are able to cast your vote on the quality of the solutions in regard to how complete, accurate, helpful and easy to understand each solution is. When you provide your feedback, each rating is adjusted accordingly. So, if you see a solution that has a poor rating that you think is a good solution, let us know by rating it. As you do, the rating will be adjusted and will become more accurate for other members of our site.

If you have any suggestions that you would like to make for our rating system, please ask a question in the Suggestions Zone of Community Support.

Thank you!
8.2

Convert HTML to RTF in VB

Asked by mystami in VB Controls, VB Objects

Tags: Visual Basic, Richtextbox, RTF, HTML

I found some code that was very helpful in accomplishing what I want, which is converting HTML to RTF.  I have seen several examples, but none of them work or work like I would like.  I have slightly modified the original to speed it up.  

The code works perfect when using it to convert just standard text, but when you attempt to use a richtextbox with formatting and have html in it  then it doesn't work.  

So instead of just setting .SelBold or .SelFontName, etc.  I would like to have the code actually convert the HTML into RTF coding.  Below is the code from the form and module that I'm testing with.  If you'd like I can provide a link to download the project.

I would greatly appreciate someone showing me how to change this code to what's going to work for me. 
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
295:
296:
297:
298:
299:
300:
301:
302:
303:
304:
305:
306:
307:
308:
309:
310:
311:
312:
313:
314:
315:
316:
317:
318:
319:
320:
321:
322:
323:
324:
325:
326:
327:
328:
329:

-------------------------------------Form 1-----------------------------------------
Option Explicit
 
Private Const IDC_HAND = 32649&
Private Const IDC_ARROW = 32512&
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
 
Private Sub cmbFont_Change()
On Error Resume Next
    txtSend.SelFontName = cmbFont.Text
    txtSend.SetFocus
End Sub
 
Private Sub cmdSend_Click()
 
If txtSend.Text = "" Then Exit Sub
    
    Dim lngSpot As Long
    
    lngSpot = Len(txtChat.Text)
    
    With txtChat
        .SelStart = Len(.Text)
        .SelLength = 0
        
        .SelBold = True
        .SelColor = vbBlue
        .SelFontSize = "10"
        .SelFontName = "Arial"
        .SelText = "mystami: " & vbTab
        
        .SelStart = lngSpot
        .SelLength = Len(.Text) - lngSpot
        .SelHangingIndent = 1400
        
        .SelStart = Len(.Text)
        .SelLength = 0
        .SelBold = False
        .SelColor = vbBlack
    End With
    
    'Here I would like to be able to Call HTMLtoRTF(txtSend.TextRTF)
    'so any custom formatting would be sent, but it does not work
    'wit the way the HTML is converted to RTF
    Call HTMLtoRTF(txtSend.Text)
    
    txtChat.SelStart = Len(txtChat.Text)
    txtChat.SelLength = 0
    txtChat.SelText = vbCrLf
    
    txtSend.Text = ""
    txtSend.SetFocus
End Sub
 
Private Sub Form_Load()
 
Dim intLoadFonts As Integer
 
For intLoadFonts = 0 To Screen.FontCount - 1
    cmbFont.AddItem Screen.Fonts(intLoadFonts)
Next
 
cmbFont.Text = "Arial"
txtSend.TabIndex = 0
End Sub
 
Private Sub txtSend_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then cmdSend_Click
End Sub
 
Private Sub picBold_Click(Index As Integer)
    If Index = 1 Then
        picBold(0).Visible = True
        picBold(1).Visible = False
        txtSend.SelBold = True
    Else
        picBold(0).Visible = False
        picBold(1).Visible = True
        txtSend.SelBold = False
    End If
    txtSend.SetFocus
End Sub
 
Private Sub picBold_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
 
SetCursor LoadCursor(0, IDC_HAND)
 
End Sub
 
Private Sub picItalic_Click(Index As Integer)
    If Index = 1 Then
        picItalic(0).Visible = True
        picItalic(1).Visible = False
        txtSend.SelItalic = True
    Else
        picItalic(0).Visible = False
        picItalic(1).Visible = True
        txtSend.SelItalic = False
    End If
    txtSend.SetFocus
End Sub
 
Private Sub picItalic_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
 
SetCursor LoadCursor(0, IDC_HAND)
 
End Sub
 
Private Sub picUnderline_Click(Index As Integer)
    If Index = 1 Then
        picUnderline(0).Visible = True
        picUnderline(1).Visible = False
        txtSend.SelUnderline = True
    Else
        picUnderline(0).Visible = False
        picUnderline(1).Visible = True
        txtSend.SelUnderline = False
    End If
    txtSend.SetFocus
End Sub
 
Private Sub picUnderline_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
 
SetCursor LoadCursor(0, IDC_HAND)
 
End Sub
--------------------------------------------------------------------------------------
------------------------------------Module 1---------------------------------------
Option Explicit
 
Public Sub HTMLtoRTF(HTML As String)
    
Dim Buf As String
Dim char As String
Dim Bumf As String
Dim a As Integer
Dim i As Integer
 
Dim strString As String
 
Bumf = HTML
 
'We set some defaults for the richedit
'Bumf = "</b></i></u><font face=""Arial"" size=""10"">" & Bumf
 
'vbCrLf' can reset the tags so lets remove them
Bumf = Replace(Bumf, vbCrLf, "")
 
'Put any text that come sbefore the first tag into the string
If Left(Bumf, 1) <> "<" Then
    If InStr(1, Bumf, "<") = 0 Then
        frmChat.txtChat.SelText = Bumf
    Else
        frmChat.txtChat.SelText = Left(Bumf, (InStr(1, Bumf, "<") - 1))
    End If
End If
 
i = InStr(1, Bumf, "<")
 
'Now we go through the string
Do While i <> 0
    char = Mid(Bumf, i, 1)
    
    'If the character is a < then we have a tag
    If char = "<" Then
        
        'So, using that as a start point we look for the clsoing bracket tag
        a = InStr(i, Bumf, ">")
        
        'We get all the text that comes after the > until the end of the string
        Buf = Mid(Bumf, a + 1, Len(Bumf) - a)
 
        'But if there's a < in there then there's another tag so we just want the text between the tags.
        If InStr(1, Buf, "<") Then Buf = Left(Buf, InStr(1, Buf, "<") - 1)
 
        'Now we get the tag by retrieving the text between the brackets and making it lowercase.
        Call Tags(Mid(Bumf, i + 1, a - (i + 1)), Buf)
 
    End If
    i = InStr(i + 1, Bumf, "<")
Loop
 
End Sub
 
 
Public Sub Tags(Tag As String, Data As String)
 
Dim a As Integer
 
'If they want to alter the font then pass the info to the font sub routine
If Left(LCase(Tag), 5) = "font " Then Call FontTags(Tag, Data): Exit Sub
        
'If the tag contains a start bracket then disregard it as a tag
'and class it as normal text
        If InStr(1, Tag, "<") Then
            a = InStr(1, Tag, "<") - 1
            frmChat.txtChat.SelText = "<" & Left(Tag, a)
            Exit Sub
        End If
 
'Now lets go thru all the fonts we have decided to handle
Select Case LCase(Tag)
        Case "b"
            'Tags = "\b "
            frmChat.txtChat.SelBold = True
            frmChat.txtChat.SelText = Data
        
        Case "/b"
            'Tags = "\b0"
            frmChat.txtChat.SelBold = False
            frmChat.txtChat.SelText = Data
            
        Case "i"
            'Tags = "\i "
            frmChat.txtChat.SelItalic = True
            frmChat.txtChat.SelText = Data
        
        Case "/i"
            'Tags = "\i0"
            frmChat.txtChat.SelItalic = False
            frmChat.txtChat.SelText = Data
        
        Case "u"
            'Tags = "\ul "
            frmChat.txtChat.SelUnderline = True
            frmChat.txtChat.SelText = Data
        
        Case "/u"
            'Tags = "\ulnone"
            frmChat.txtChat.SelUnderline = False
            frmChat.txtChat.SelText = Data
 
        Case "s"
            'Tags = "\strike "
            frmChat.txtChat.SelStrikeThru = True
            frmChat.txtChat.SelText = Data
        
        Case "/s"
            'Tags = "\strike0"
            frmChat.txtChat.SelStrikeThru = False
            frmChat.txtChat.SelText = Data
 
        'IF you know HTML then you know this is a break tag
        'it's used to start a new line
        Case "br", "/font"
            frmChat.txtChat.SelText = Data
            
        'If there are any unrecognised tags  just post it's text using the current sel settings.
        Case Else
            frmChat.txtChat.SelText = "<" & Tag & ">" & Data
            
        End Select
        
        
End Sub
 
Private Sub FontTags(Tag As String, Data As String)
Dim a As Integer
Dim Tag2 As String
Dim Tag3 As String
Dim strString As String
 
'MsgBox Tag & ": " & Data
 
'We know the tag is a font styling tag so we can remove the font bit
Tag = Right(Tag, Len(Tag) - 5)
 
'First lets deal with font face tags.
'The string for the name must be in ""'s
If InStr(1, LCase(Tag), "face=") Then
    Tag2 = Right(Tag, Len(Tag) - (InStr(1, LCase(Tag), "face=") + 5))
    Tag2 = Left(Tag2, InStr(1, Tag2, Chr(34)) - 1)
    
    'strString = "{\fonttbl{\f" & "0" & "\fnil\fcharset0 " & Trim(Tag2) & ";}"
    'MsgBox "strString: " & strString
    'strString = Trim(Tag2)
    frmChat.txtChat.SelFontName = Trim(Tag2)
End If
 
If InStr(1, LCase(Tag), "color=") Then
    Tag2 = Right(Tag, Len(Tag) - (InStr(1, LCase(Tag), "color=") + 6))
    On Error Resume Next
    Tag2 = Left(Tag2, InStr(1, Tag2, Chr(34)) - 1)
    frmChat.txtChat.SelColor = HexToDecimal(Trim(Tag2))
End If
 
 
'Now lets see if they want to change the fonts size
If InStr(1, LCase(Tag), "size=") Then
    Tag2 = Right(Tag, Len(Tag) - (InStr(1, LCase(Tag), "size=") + 5))
    Tag2 = Left(Tag2, InStr(1, Tag2, Chr(34)) - 1)
    If Val(Tag2) > 0 Then frmChat.txtChat.SelFontSize = Val(Tag2)
End If
 
'Now we've set any font face and size requests we can post the string
'rchHTML.SelText = Data
frmChat.txtChat.SelText = Data
End Sub
 
Function HexToDecimal(ByVal strHex As String) As Long
 
'this function converts any hexidecimal color value
'(e.g. "0000FF" = Blue) to decimal color value.
 
Dim lngDecimal As Long, strCharHex As String, lngColor As Long
Dim lngChar As Long
 
If Left$(strHex$, 1) = "#" Then strHex$ = Right$(strHex$, 6)
  
strHex$ = Right$(strHex$, 2) & Mid$(strHex$, 3, 2) & Left$(strHex$, 2)
 
  For lngChar& = Len(strHex$) To 1 Step -1
    strCharHex$ = Mid$(UCase$(strHex$), lngChar&, 1)
    
       Select Case strCharHex$
          Case 0 To 9
             lngDecimal& = CLng(strCharHex$)
          Case Else 'A,B,C,D,E,F
             lngDecimal& = CLng(Chr$((Asc(strCharHex$) - 17))) + 10
       End Select
       
    lngColor& = lngColor& + lngDecimal& * 16 ^ (Len(strHex$) - lngChar&)
  Next lngChar&
  
HexToDecimal = lngColor&
 
End Function
--------------------------------------------------------------------------------------
[+][-]04/21/09 06:24 PM, ID: 24200802

At Experts Exchange, members can ask their questions to thousands of technology professionals, also known as Experts. Experts compete and collaborate to answer those questions by leaving comments like this one.

Start your 30-day free trial to view this Expert Comment or ask the Experts your question.

 
[+][-]04/21/09 06:53 PM, ID: 24200909

Often, when Experts are collaborating with members who have asked questions, they will request additional information about the problem. Askers respond with an author comment like this one.

Start your 30-day free trial to view this Author Comment or ask the Experts your question.

 
[+][-]04/24/09 07:38 AM, ID: 24225755

Often, when Experts are collaborating with members who have asked questions, they will request additional information about the problem. Askers respond with an author comment like this one.

Start your 30-day free trial to view this Author Comment or ask the Experts your question.

 
[+][-]05/09/09 08:11 PM, ID: 24346692

View this solution now by starting your 30-day free trial. Setting up your free trial is quick, easy, and secure. We will return you to this solution, unlocked, when you're done.

 

About this solution

Zones: VB Controls, VB Objects
Tags: Visual Basic, Richtextbox, RTF, HTML
Sign Up Now!
Solution Provided By: mystami
Participating Experts: 1
Solution Grade: A
 
 
 
Loading Advertisement...
20091028-EE-VQP-87 - Hierarchy / EE_QW_3_20080625