HTML --> RTF

Previous  Top  Next

    
 

 

 

Code:

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

 

©Drkb::04285

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