Articles   Members Online: 3
-Article/Tip Search
-News Group Search over 21 Million news group articles.
-Delphi/Pascal
-CBuilder/C++
-C#Builder/C#
-JBuilder/Java
-Kylix
Member Area
-Home
-Account Center
-Top 10 NEW!!
-Submit Article/Tip
-Forums Upgraded!!
-My Articles
-Edit Information
-Login/Logout
-Become a Member
-Why sign up!
-Newsletter
-Chat Online!
-Indexes NEW!!
Employment
-Build your resume
-Find a job
-Post a job
-Resume Search
Contacts
-Contacts
-Feedbacks
-Link to us
-Privacy/Disclaimer
Embarcadero
Visit Embarcadero
Embarcadero Community
JEDI
Links
How to convert HTML to RTF Turn on/off line numbers in source code. Switch to Orginial background IDE or DSP color Comment or reply to this aritlce/tip for discussion. Bookmark this article to my favorite article(s). Print this article
08-Mar-04
Category
Reporting /Printing
Language
Delphi 3.x
Views
179
User Rating
8
# Votes
1
Replies
0
Publisher:
DSP, Administrator
Reference URL:
DKB
			Author: Falk Schulze

How to convert HTML to RTF?

Answer:

1   { HTML to RTF by Falk Schulze }
2   
3   procedure HTMLtoRTF(html: string; var rtf: TRichedit);
4   var
5     i, dummy, row: Integer;
6     cfont: TFont; { Standard sschrift }
7     Tag, tagparams: string;
8     params: TStringList;
9   
10    function GetTag(s: string; var i: Integer; var Tag, tagparams: string): Boolean;
11    var
12      a_tag: Boolean;
13    begin
14      GetTag := False;
15      Tag := '';
16      tagparams := '';
17      a_tag := False;
18  
19      while i <= Length(s) do
20      begin
21        Inc(i);
22        // es wird nochein tag geöffnet --> das erste war kein tag;
23        if s[i] = '<' then
24        begin
25          GetTag := False;
26          Exit;
27        end;
28  
29        if s[i] = '>' then
30        begin
31          GetTag := True;
32          Exit;
33        end;
34  
35        if not a_tag then
36        begin
37          if s[i] = ' ' then
38          begin
39            if Tag <> '' then
40              a_tag := True;
41          end
42          else
43            Tag := Tag + s[i];
44        end
45        else
46          tagparams := tagparams + s[i];
47      end;
48    end;
49  
50    procedure GetTagParams(tagparams: string; var params: TStringList);
51    var
52      i: Integer;
53      s: string;
54      gleich: Boolean;
55  
56      // kontrolliert ob nach dem zeichen bis zum nächsten zeichen ausser
57      // leerzeichen ein Ist-Gleich-Zeichen kommt
58      function notGleich(s: string; i: Integer): Boolean;
59      begin
60        notGleich := True;
61        while i <= Length(s) do
62        begin
63          Inc(i);
64          if s[i] = '=' then
65          begin
66            notGleich := False;
67            Exit;
68          end
69          else if s[i] <> ' ' then
70            Exit;
71        end;
72      end;
73    begin
74      Params.Clear;
75      s := '';
76      for i := 1 to Length(tagparams) do
77      begin
78        if (tagparams[i] <> ' ') then
79        begin
80          if tagparams[i] <> '=' then
81            gleich := False;
82          if (tagparams[i] <> '''') and (tagparams[i] <> '"') then
83            s := s + tagparams[i]
84        end
85        else
86        begin
87          if (notGleich(tagparams, i)) and (not Gleich) then
88          begin
89            params.Add(s);
90            s := '';
91          end
92          else
93            Gleich := True;
94        end;
95      end;
96      params.Add(s);
97    end;
98  
99    function HtmlToColor(Color: string): TColor;
100   begin
101     Result := StringToColor('$' + Copy(Color, 6, 2) + Copy(Color, 4,
102       2) + Copy(Color, 2, 2));
103   end;
104 
105   procedure TransformSpecialChars(var s: string; i: Integer);
106   var
107     c: string;
108     z, z2: Byte;
109     i2: Integer;
110   const
111     nchars = 9;
112     chars: array[1..nchars, 1..2] of string =
113     (('Ö', 'Ö'), ('ö', 'ö'), ('Ä', 'Ä'), ('ä', 'ä'),
114       ('Ü', 'Ü'), ('ü', 'ü'), ('ß', 'ß'), ('<', '<'),
115       ('>', '>'));
116   begin
117     // Maximal die nächsten 7 zeichen auf sonderzeichen überprüfen
118     c := '';
119     i2 := i;
120     for z := 1 to 7 do
121     begin
122       c := c + s[i2];
123       for z2 := 1 to nchars do
124       begin
125         if chars[z2, 1] = c then
126         begin
127           Delete(s, i, Length(c));
128           Insert(chars[z2, 2], s, i);
129           Exit;
130         end;
131       end;
132       Inc(i2);
133     end;
134   end;
135 
136   // HtmlTag Schriftgröße in pdf größe umwandeln
137   function CalculateRTFSize(pt: Integer): Integer;
138   begin
139     case pt of
140       1: Result := 6;
141       2: Result := 9;
142       3: Result := 12;
143       4: Result := 15;
144       5: Result := 18;
145       6: Result := 22;
146     else
147       Result := 30;
148     end;
149   end;
150 
151   // Die Font-Stack Funktionen
152 type
153   fontstack = record
154     Font: array[1..100] of tfont;
155     Pos: Byte;
156   end;
157 
158   procedure CreateFontStack(var s: fontstack);
159   begin
160     s.Pos := 0;
161   end;
162 
163   procedure PushFontStack(var s: Fontstack; fnt: TFont);
164   begin
165     Inc(s.Pos);
166     s.Font[s.Pos] := TFont.Create;
167     s.Font[s.Pos].Assign(fnt);
168   end;
169 
170   procedure PopFontStack(var s: Fontstack; var fnt: TFont);
171   begin
172     if (s.Font[s.Pos] <> nil) and (s.Pos > 0) then
173     begin
174       fnt.Assign(s.Font[s.Pos]);
175       // vom stack nehmen
176       s.Font[s.Pos].Free;
177       Dec(s.Pos);
178     end;
179   end;
180 
181   procedure FreeFontStack(var s: Fontstack);
182   begin
183     while s.Pos > 0 do
184     begin
185       s.Font[s.Pos].Free;
186       Dec(s.Pos);
187     end;
188   end;
189 var
190   fo_cnt: array[1..1000] of tfont;
191   fo_liste: array[1..1000] of Boolean;
192   fo_pos: TStringList;
193   fo_stk: FontStack;
194   wordwrap, liste: Boolean;
195 begin
196   CreateFontStack(fo_Stk);
197 
198   fo_Pos := TStringList.Create;
199 
200   rtf.Lines.BeginUpdate;
201   rtf.Lines.Clear;
202   // Das wordwrap vom richedit merken
203   wordwrap := rtf.wordwrap;
204   rtf.WordWrap := False;
205 
206   // erste Zeile hinzufügen
207   rtf.Lines.Add('');
208   Params := TStringList.Create;
209 
210   cfont := TFont.Create;
211   cfont.Assign(rtf.Font);
212 
213   i := 1;
214   row := 0;
215   Liste := False;
216   // Den eigentlichen Text holen und die Formatiorung merken
217   rtf.selstart := 0;
218   if Length(html) = 0 then
219     Exit;
220   repeat;
221 
222     if html[i] = '<' then
223     begin
224       dummy := i;
225       GetTag(html, i, Tag, tagparams);
226       GetTagParams(tagparams, params);
227 
228       // Das Font-Tag
229       if Uppercase(Tag) = 'FONT' then
230       begin
231         // Schrift auf fontstack sichern
232         pushFontstack(fo_stk, cfont);
233         if params.Values['size'] <> '' then
234           cfont.Size := CalculateRTFSize(StrToInt(params.Values['size']));
235 
236         if params.Values['color'] <> '' then
237           cfont.Color :=
238             htmltocolor(params.Values['color']);
239       end
240       else if Uppercase(Tag) = '/FONT' then
241         popFontstack(fo_stk, cfont)
242       else {// Die H-Tags-Überschriften } if Uppercase(Tag) = 'H1' then
243         begin
244           // Schrift auf fontstack sichern
245           pushFontstack(fo_stk, cfont);
246           cfont.Size := 6;
247         end
248         else if Uppercase(Tag) = '/H1' then
249           popFontstack(fo_stk, cfont)
250         else {// Die H-Tags-Überschriften } if Uppercase(Tag) = 'H2' then
251           begin
252             // Schrift auf fontstack sichern
253             pushFontstack(fo_stk, cfont);
254             cfont.Size := 9;
255           end
256           else if Uppercase(Tag) = '/H2' then
257             popFontstack(fo_stk, cfont)
258           else {// Die H-Tags-Überschriften } if Uppercase(Tag) = 'H3' then
259             begin
260               // Schrift auf fontstack sichern
261               pushFontstack(fo_stk, cfont);
262               cfont.Size := 12;
263             end
264             else if Uppercase(Tag) = '/H3' then
265               popFontstack(fo_stk, cfont)
266             else {// Die H-Tags-Überschriften } if Uppercase(Tag) = 'H4' then
267               begin
268                 // Schrift auf fontstack sichern
269                 pushFontstack(fo_stk, cfont);
270                 cfont.Size := 15;
271               end
272               else if Uppercase(Tag) = '/H4' then
273                 popFontstack(fo_stk, cfont)
274               else {// Die H-Tags-Überschriften } if Uppercase(Tag) = 'H5' then
275                 begin
276                   // Schrift auf fontstack sichern
277                   pushFontstack(fo_stk, cfont);
278                   cfont.Size := 18;
279                 end
280                 else if Uppercase(Tag) = '/H5' then
281                   popFontstack(fo_stk, cfont)
282                 else {// Die H-Tags-Überschriften } if Uppercase(Tag) = 'H6' then
283                   begin
284                     // Schrift auf fontstack sichern
285                     pushFontstack(fo_stk, cfont);
286                     cfont.Size := 22;
287                   end
288                   else if Uppercase(Tag) = '/H6' then
289                     popFontstack(fo_stk, cfont)
290                   else {// Die H-Tags-Überschriften } if Uppercase(Tag) = 'H7' then
291                     begin
292                       // Schrift auf fontstack sichern
293                       pushFontstack(fo_stk, cfont);
294                       cfont.Size := 27;
295                     end
296                     else if Uppercase(Tag) = '/H7' then
297                       popFontstack(fo_stk, cfont)
298                     else // Bold-Tag
299                       if Uppercase(Tag) = 'B' then
300                         cfont.Style := cfont.Style + [fsbold]
301                       else if Uppercase(Tag) = '/B' then
302                         cfont.Style := cfont.Style - [fsbold]
303                       else // Italic-Tag
304                         if Uppercase(Tag) = 'I' then
305                           cfont.Style := cfont.Style + [fsitalic]
306                         else if Uppercase(Tag) = '/I' then
307                           cfont.Style := cfont.Style - [fsitalic]
308                         else // underline-Tag
309                           if Uppercase(Tag) = 'U' then
310                             cfont.Style := cfont.Style + [fsunderline]
311                           else if Uppercase(Tag) = '/U' then
312                             cfont.Style := cfont.Style - [fsunderline]
313                           else // underline-Tag
314                             if Uppercase(Tag) = 'UL' then
315                               liste := True
316                             else if Uppercase(Tag) = '/UL' then
317                             begin
318                               liste := False;
319                               rtf.Lines.Add('');
320                               Inc(row);
321                               rtf.Lines.Add('');
322                               Inc(row);
323                             end
324                             else // BR - Breakrow tag
325                               if (Uppercase(Tag) = 'BR') or (Uppercase(Tag) = 'LI')
326                                 then
327                               begin
328                                 rtf.Lines.Add('');
329                                 Inc(row);
330                               end;
331 
332       // unbekanntes tag als text ausgeben
333       // else rtf.Lines[row]:=RTF.lines[row]+'<'+tag+' '+tagparams+'>';
334 
335       fo_pos.Add(IntToStr(rtf.selstart));
336       fo_cnt[fo_pos.Count] := TFont.Create;
337       fo_cnt[fo_pos.Count].Assign(cfont);
338       fo_liste[fo_pos.Count] := liste;
339     end
340     else
341     begin
342       // Spezialzeichen übersetzen
343       if html[i] = '&' then
344         Transformspecialchars(html, i);
345 
346       if (Ord(html[i]) <> 13) and (Ord(html[i]) <> 10) then
347         rtf.Lines[row] := RTF.Lines[row] + html[i];
348     end;
349 
350     Inc(i);
351 
352   until i >= Length(html);
353   // dummy eintragen
354   fo_pos.Add('999999');
355 
356   // Den fertigen Text formatieren
357   for i := 0 to fo_pos.Count - 2 do
358   begin
359     rtf.SelStart := StrToInt(fo_pos[i]);
360     rtf.SelLength := StrToInt(fo_pos[i + 1]) - rtf.SelStart;
361     rtf.SelAttributes.Style := fo_cnt[i + 1].Style;
362     rtf.SelAttributes.Size := fo_cnt[i + 1].Size;
363     rtf.SelAttributes.Color := fo_cnt[i + 1].Color;
364 
365     // die font wieder freigeben;
366     fo_cnt[i + 1].Free;
367   end;
368 
369   // die Paragraphen also Listen setzen
370   i := 0;
371   while i <= fo_pos.Count - 2 do
372   begin
373     if fo_liste[i + 1] then
374     begin
375       rtf.SelStart := StrToInt(fo_pos[i + 1]);
376       while fo_liste[i + 1] do
377         Inc(i);
378       rtf.SelLength := StrToInt(fo_pos[i - 1]) - rtf.SelStart;
379       rtf.Paragraph.Numbering := nsBullet;
380     end;
381     Inc(i);
382   end;
383   rtf.Lines.EndUpdate;
384   Params.Free;
385   cfont.Free;
386   rtf.WordWrap := wordwrap;
387   FreeFontStack(fo_stk);
388 end;


			
Vote: How useful do you find this Article/Tip?
Bad Excellent
1 2 3 4 5 6 7 8 9 10

 

Advertisement
Share this page
Advertisement
Download from Google

Copyright © Mendozi Enterprises LLC