Kylix
Tips

NEW TIPS
Database (90)
Files (138)
Forms (107)
Graphic (116)
IDE (21)
Indy (5)
Internet / LAN (131)
IntraWeb (0)
Math (76)
Misc (127)
Multimedia (45)
Objects/
ActiveX (51)

OpenTools API (3)
Printing (35)
Strings (83)
System (268)
VCL (243)

Search Tip
Top15
Add new Tip

Forum

...Convert HTML to RTF?
Author: Falk Schulze
Homepage: http://www.msy.de.tt
[ Print tip ]    

Tip Rating (29):  
     



{ HTML to RTF by Falk Schulze }

procedure HTMLtoRTF(html: stringvar rtf: TRichedit);
var
  
i, dummy, row: Integer;
  cfont: TFont; { Standard sschrift }
  
Tag, tagparams: string;
  params: TStringList;

  function GetTag(s: stringvar 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: stringvar 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 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] <> niland (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;

Rate this tip:

poor
very good


Copyright  Torry's Delphi Pages Torry's Delphi Pages Maintained by Simon Grossenbacher Notes? Comments? Feel free to send... Copyright 1996-2001