Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

HTML > RTF

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

Взято с сайта https://www.swissdelphicenter.ch/en/tipsindex.php