{ HTML to RTF by Falk Schulze }
procedure HTMLtoRTF(html: string; var rtf: TRichedit);
var
 i, dummy, row: Integer;
 cfont: TFont;
 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);
  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;
  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
  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;
 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;

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]);
  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;
 wordwrap := rtf.wordwrap;
 rtf.WordWrap := False;
 rtf.Lines.Add('');
 Params := TStringList.Create;

 cfont := TFont.Create;
 cfont.Assign(rtf.Font);

 i := 1;
 row := 0;
 Liste := False;
 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);
  if Uppercase(Tag) = 'FONT' then
  begin
  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
  if Uppercase(Tag) = 'H1' then
  begin
  pushFontstack(fo_stk, cfont);
  cfont.Size := 6;
  end
  else if Uppercase(Tag) = '/H1' then popFontstack(fo_stk, cfont)
  else
  if Uppercase(Tag) = 'H2' then
  begin
  pushFontstack(fo_stk, cfont);
  cfont.Size := 9;
  end
  else if Uppercase(Tag) = '/H2' then popFontstack(fo_stk, cfont)
  else
  if Uppercase(Tag) = 'H3' then
  begin
  pushFontstack(fo_stk, cfont);
  cfont.Size := 12;
  end
  else if Uppercase(Tag) = '/H3' then popFontstack(fo_stk, cfont)
  else
  if Uppercase(Tag) = 'H4' then
  begin
  pushFontstack(fo_stk, cfont);
  cfont.Size := 15;
  end
  else if Uppercase(Tag) = '/H4' then popFontstack(fo_stk, cfont)
  else
  if Uppercase(Tag) = 'H5' then
  begin
  pushFontstack(fo_stk, cfont);
  cfont.Size := 18;
  end
  else if Uppercase(Tag) = '/H5' then popFontstack(fo_stk, cfont)
  else
  if Uppercase(Tag) = 'H6' then
  begin
  pushFontstack(fo_stk, cfont);
  cfont.Size := 22;
  end
  else if Uppercase(Tag) = '/H6' then popFontstack(fo_stk, cfont)
  else
  if Uppercase(Tag) = 'H7' then
  begin
  pushFontstack(fo_stk, cfont);
  cfont.Size := 27;
  end
  else if Uppercase(Tag) = '/H7' then popFontstack(fo_stk, cfont)
  else
  if Uppercase(Tag) = 'B' then cfont.Style := cfont.Style + [fsbold]
  else if Uppercase(Tag) = '/B' then cfont.Style := cfont.Style - [fsbold]
  else
  if Uppercase(Tag) = 'I' then cfont.Style := cfont.Style + [fsitalic]
  else if Uppercase(Tag) = '/I' then cfont.Style := cfont.Style - [fsitalic]
  else
  if Uppercase(Tag) = 'U' then cfont.Style := cfont.Style + [fsunderline]
  else if Uppercase(Tag) = '/U' then cfont.Style := cfont.Style - [fsunderline]
  else
  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
  if (Uppercase(Tag) = 'BR') or (Uppercase(Tag) = 'LI') then
  begin
  rtf.Lines.Add('');
  Inc(row);
  end;
  // 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
  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);
 fo_pos.Add('999999');
 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;
  fo_cnt[i + 1].Free;
 end;
 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;