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;
|
