HTML转换RTF

HTML 转换RTF
{ HTML to RTF by Falk Schulze }
procedure HTMLtoRTF(html: string; var rtf: TRichedit);
var
 i, dummy, row: Integer;
 cfont: TFont; { Standard sschrift }
 Tag, tagparams: string;
 params: TStringList;
 function GetTag(s: string; var i: Integer; var Tag, tagparams: string): Boolean;
 var  
   a_tag: Boolean;
 begin
   GetTag  := False;
   Tag  := '';
   tagparams := '';
   a_tag  := False;
   while i <= Length(s) do  
   begin
     Inc(i);
     // es wird nochein tag ge öffnet --> das erste war kein tag;
     if s[i] = '<' then  
     begin
       GetTag := False;
       Exit;
     end;
     if s[i] = '>' then  
     begin
       GetTag := True;
       Exit;
     end;
     if not a_tag then  
     begin
       if s[i] = ' ' then  
       begin
         if Tag <> '' then a_tag := True;
       end  
       else  
         Tag := Tag + s[i];
     end  
     else
       tagparams := tagparams + s[i];
   end;
 end;
 procedure GetTagParams(tagparams: string; var params: TStringList);
 var  
   i: Integer;
   s: string;
   gleich: Boolean;
   // kontrolliert ob nach dem zeichen bis zum nächsten zeichen ausser
   // leerzeichen ein Ist-Gleich-Zeichen kommt
   function notGleich(s: string; i: Integer): Boolean;
   begin
     notGleich := True;
     while i <= Length(s) do  
     begin
       Inc(i);
       if s[i] = '=' then  
       begin
         notGleich := False;
         Exit;
       end  
       else if s[i] <> ' ' then Exit;
     end;
   end;
 begin
   Params.Clear;
   s := '';
   for i := 1 to Length(tagparams) do  
   begin
     if (tagparams[i] <> ' ') then  
     begin
       if tagparams[i] <> '=' then gleich := False;
       if (tagparams[i] <> '''') and (tagparams[i] <> '"') then s := s + tagparams[i]
     end  
     else  
     begin
       if (notGleich(tagparams, i)) and (not Gleich) then  
       begin
         params.Add(s);
         s := '';
       end  
       else  
         Gleich := True;
     end;
   end;
   params.Add(s);
 end;
 function HtmlToColor(Color: string): TColor;
 begin
   Result := StringToColor('$' + Copy(Color, 6, 2) + Copy(Color, 4,  2) + Copy(Color, 2, 2));
 end;
 procedure TransformSpecialChars(var s: string; i: Integer);
 var  
   c: string;
   z, z2: Byte;
   i2: Integer;
 const  
   nchars = 9;
   chars: array[1..nchars, 1..2] of string =
     (('Ö', 'Ö'), ('ö', 'ö'), ('Ä', 'Ä'), ('ä', 'ä'),
     ('Ü', 'Ü'), ('ü', 'ü'), ('ß', 'ß'), ('<', '<'),
     ('>', '>'));
 begin
   // Maximal die nächsten 7 zeichen auf sonderzeichen überprüfen
   c  := '';
   i2 := i;
   for z := 1 to 7 do  
   begin
     c := c + s[i2];
     for z2 := 1 to nchars do  
     begin
       if chars[z2, 1] = c then  
       begin
         Delete(s, i, Length(c));
         Insert(chars[z2, 2], s, i);
         Exit;
       end;
     end;
     Inc(i2);
   end;
 end;
 // HtmlTag Schriftgröße in pdf größe umwandeln
 function CalculateRTFSize(pt: Integer): Integer;
 begin
   case pt of
     1: Result := 6;
     2: Result := 9;
     3: Result := 12;
     4: Result := 15;
     5: Result := 18;
     6: Result := 22;
     else  
       Result := 30;
   end;
 end;
 // Die Font-Stack Funktionen
type  
 fontstack = record
   Font: array[1..100] of tfont;
   Pos: Byte;
 end;
 procedure CreateFontStack(var s: fontstack);
 begin
   s.Pos := 0;
 end;
 procedure PushFontStack(var s: Fontstack; fnt: TFont);
 begin
   Inc(s.Pos);
   s.Font[s.Pos] := TFont.Create;
   s.Font[s.Pos].Assign(fnt);
 end;
 procedure PopFontStack(var s: Fontstack; var fnt: TFont);
 begin
   if (s.Font[s.Pos] <> nil) and (s.Pos > 0) then  
   begin
     fnt.Assign(s.Font[s.Pos]);
     // vom stack nehmen
     s.Font[s.Pos].Free;
     Dec(s.Pos);
   end;
 end;
 procedure FreeFontStack(var s: Fontstack);
 begin
   while s.Pos > 0 do  
   begin
     s.Font[s.Pos].Free;
     Dec(s.Pos);
   end;
 end;
var  
 fo_cnt: array[1..1000] of tfont;
 fo_liste: array[1..1000] of Boolean;
 fo_pos: TStringList;
 fo_stk: FontStack;
 wordwrap, liste: Boolean;
begin
 CreateFontStack(fo_Stk);
 fo_Pos := TStringList.Create;
 rtf.Lines.BeginUpdate;
 rtf.Lines.Clear;
 // Das wordwrap vom richedit merken
 wordwrap  := rtf.wordwrap;
 rtf.WordWrap := False;
 // erste Zeile hinzufügen
 rtf.Lines.Add('');
 Params := TStringList.Create;
 cfont := TFont.Create;
 cfont.Assign(rtf.Font);
 i := 1;
 row := 0;
 Liste := False;
 // Den eigentlichen Text holen und die Formatiorung merken
 rtf.selstart := 0;
 if Length(html) = 0 then Exit;
 repeat;
   if html[i] = '<' then  
   begin
     dummy := i;
     GetTag(html, i, Tag, tagparams);
     GetTagParams(tagparams, params);
     // Das Font-Tag
     if Uppercase(Tag) = 'FONT' then  
     begin
       // Schrift auf fontstack sichern
       pushFontstack(fo_stk, cfont);
       if params.Values['size'] <> '' then
         cfont.Size := CalculateRTFSize(StrToInt(params.Values['size']));
       if params.Values['color'] <> '' then cfont.Color :=
           htmltocolor(params.Values['color']);
     end  
     else if Uppercase(Tag) = '/FONT' then  popFontstack(fo_stk, cfont)  
     else // Die H-Tags-Überschriften
     if Uppercase(Tag) = 'H1' then  
     begin
       // Schrift auf fontstack sichern
       pushFontstack(fo_stk, cfont);
       cfont.Size := 6;
     end  
     else if Uppercase(Tag) = '/H1' then  popFontstack(fo_stk, cfont)  
     else // Die H-Tags-Überschriften
     if Uppercase(Tag) = 'H2' then  
     begin
       // Schrift auf fontstack sichern
       pushFontstack(fo_stk, cfont);
       cfont.Size := 9;
     end  
     else if Uppercase(Tag) = '/H2' then  popFontstack(fo_stk, cfont)  
     else // Die H-Tags-Überschriften
     if Uppercase(Tag) = 'H3' then  
     begin
       // Schrift auf fontstack sichern
       pushFontstack(fo_stk, cfont);
       cfont.Size := 12;
     end  
     else if Uppercase(Tag) = '/H3' then  popFontstack(fo_stk, cfont)  
     else // Die H-Tags-Überschriften
     if Uppercase(Tag) = 'H4' then  
     begin
       // Schrift auf fontstack sichern
       pushFontstack(fo_stk, cfont);
       cfont.Size := 15;
     end  
     else if Uppercase(Tag) = '/H4' then  popFontstack(fo_stk, cfont)  
     else // Die H-Tags-Überschriften
     if Uppercase(Tag) = 'H5' then  
     begin
       // Schrift auf fontstack sichern
       pushFontstack(fo_stk, cfont);
       cfont.Size := 18;
     end  
     else if Uppercase(Tag) = '/H5' then  popFontstack(fo_stk, cfont)  
     else // Die H-Tags-Überschriften
     if Uppercase(Tag) = 'H6' then  
     begin
       // Schrift auf fontstack sichern
       pushFontstack(fo_stk, cfont);
       cfont.Size := 22;
     end  
     else if Uppercase(Tag) = '/H6' then  popFontstack(fo_stk, cfont)  
     else // Die H-Tags-Überschriften
     if Uppercase(Tag) = 'H7' then  
     begin
       // Schrift auf fontstack sichern
       pushFontstack(fo_stk, cfont);
       cfont.Size := 27;
     end  
     else if Uppercase(Tag) = '/H7' then  popFontstack(fo_stk, cfont)  
     else // Bold-Tag
     if Uppercase(Tag) = 'B' then cfont.Style := cfont.Style + [fsbold]  
     else if Uppercase(Tag) = '/B' then cfont.Style := cfont.Style - [fsbold]  
     else // Italic-Tag
     if Uppercase(Tag) = 'I' then cfont.Style := cfont.Style + [fsitalic]  
     else if Uppercase(Tag) = '/I' then cfont.Style := cfont.Style - [fsitalic]  
     else // underline-Tag
     if Uppercase(Tag) = 'U' then cfont.Style := cfont.Style + [fsunderline]  
     else if Uppercase(Tag) = '/U' then cfont.Style := cfont.Style - [fsunderline]  
     else // underline-Tag
     if Uppercase(Tag) = 'UL' then liste := True  
     else if Uppercase(Tag) = '/UL' then  
     begin
       liste := False;
       rtf.Lines.Add('');
       Inc(row);
       rtf.Lines.Add('');
       Inc(row);
     end  
     else // BR - Breakrow tag
     if (Uppercase(Tag) = 'BR') or (Uppercase(Tag) = 'LI') then  
     begin
       rtf.Lines.Add('');
       Inc(row);
     end;
     // unbekanntes tag als text ausgeben
     // else rtf.Lines[row]:=RTF.lines[row]+'<'+tag+' '+tagparams+'>';
     fo_pos.Add(IntToStr(rtf.selstart));
     fo_cnt[fo_pos.Count] := TFont.Create;
     fo_cnt[fo_pos.Count].Assign(cfont);
     fo_liste[fo_pos.Count] := liste;
   end  
   else  
   begin
     // Spezialzeichen übersetzen
     if html[i] = '&' then Transformspecialchars(html, i);
     if (Ord(html[i]) <> 13) and (Ord(html[i]) <> 10) then
       rtf.Lines[row] := RTF.Lines[row] + html[i];
   end;
   Inc(i);
 until i >= Length(html);
 // dummy eintragen
 fo_pos.Add('999999');
 // Den fertigen Text formatieren
 for i := 0 to fo_pos.Count - 2 do  
 begin
   rtf.SelStart := StrToInt(fo_pos[i]);
   rtf.SelLength := StrToInt(fo_pos[i + 1]) - rtf.SelStart;
   rtf.SelAttributes.Style := fo_cnt[i + 1].Style;
   rtf.SelAttributes.Size := fo_cnt[i + 1].Size;
   rtf.SelAttributes.Color := fo_cnt[i + 1].Color;
   // die font wieder freigeben;
   fo_cnt[i + 1].Free;
 end;
 // die Paragraphen also Listen setzen
 i := 0;
 while i <= fo_pos.Count - 2 do  
 begin
   if fo_liste[i + 1] then  
   begin
     rtf.SelStart := StrToInt(fo_pos[i + 1]);
     while fo_liste[i + 1] do Inc(i);
     rtf.SelLength := StrToInt(fo_pos[i - 1]) - rtf.SelStart;
     rtf.Paragraph.Numbering := nsBullet;
   end;
   Inc(i);
 end;
 rtf.Lines.EndUpdate;
 Params.Free;
 cfont.Free;
 rtf.WordWrap := wordwrap;
 FreeFontStack(fo_stk);
end;