Оформил: DeeCo
Автор: http://www.swissdelphicenter.ch

{ 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 geoffnet --> 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 nachsten 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 =
       (('O', 'O'), ('o', 'o'), ('A', 'A'), ('a', 'a'),
       ('U', 'U'), ('u', 'u'), ('?', '?'), ('<', '<'),
       ('>', '>'));
   begin
     // Maximal die nachsten 7 zeichen auf sonderzeichen uberprufen 
    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 Schriftgro?e in pdf gro?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 hinzufugen 
  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-Uberschriften 
      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-Uberschriften 
      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-Uberschriften 
      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-Uberschriften 
      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-Uberschriften 
      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-Uberschriften 
      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-Uberschriften 
      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 ubersetzen 
      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;