Html2rft And Rtf2html

Тема в разделе "Delphi - FAQ", создана пользователем fishMD, 20 июл 2005.

Статус темы:
Закрыта.
  1. fishMD

    fishMD Гость

    интерестно.... есть ли такая компонента, или еще чето в этом роде? Мож кому встречалось?
    Или как это сделать?....
     
  2. Poseidon

    Poseidon Гость

    RTF-->HTML
    Код (Text):
    Приведу программу, которую я использую для преобразования содержимого RichEdit в SGML-код. Она не формирует полный HTML-аналог, но вы сами можете добавить необходимый RTF-код и его интерпретацию в HTML-тэги.

    Код содержит интуитивно понятные комментарии и строки на шведском языке, нецелесообразные для перевода.

    function rtf2sgml(text: string): string;
    {Funktion for att konvertera en RTF-rad till SGML-text.}
    var
    temptext: string;
    start: integer;
    begin
    text := stringreplaceall(text, '&', '##amp;');
    text := stringreplaceall(text, '##amp', '&amp');
    text := stringreplaceall(text, '\' + chr(39) + 'e5', 'å');
    text := stringreplaceall(text, '\' + chr(39) + 'c5', 'Å');
    text := stringreplaceall(text, '\' + chr(39) + 'e4', 'ä');
    text := stringreplaceall(text, '\' + chr(39) + 'c4', 'Ä');
    text := stringreplaceall(text, '\' + chr(39) + 'f6', 'ö');
    text := stringreplaceall(text, '\' + chr(39) + 'd6', 'Ö');
    text := stringreplaceall(text, '\' + chr(39) + 'e9', 'é');
    text := stringreplaceall(text, '\' + chr(39) + 'c9', 'É');
    text := stringreplaceall(text, '\' + chr(39) + 'e1', 'á');
    text := stringreplaceall(text, '\' + chr(39) + 'c1', 'Á');
    text := stringreplaceall(text, '\' + chr(39) + 'e0', 'à');
    text := stringreplaceall(text, '\' + chr(39) + 'c0', 'À');
    text := stringreplaceall(text, '\' + chr(39) + 'f2', 'ò');
    text := stringreplaceall(text, '\' + chr(39) + 'd2', 'Ò');
    text := stringreplaceall(text, '\' + chr(39) + 'fc', 'ü');
    text := stringreplaceall(text, '\' + chr(39) + 'dc', 'Ü');
    text := stringreplaceall(text, '\' + chr(39) + 'a3', '£');
    text := stringreplaceall(text, '\}', '#]#');
    text := stringreplaceall(text, '\{', '#[#');
    text := stringreplaceall(text, '{\rtf1\ansi\deff0\deftab720', ''); {Skall alltid tas bort}
    text := stringreplaceall(text, '{\fonttbl', ''); {Skall alltid tas bort}
    text := stringreplaceall(text, '{\f0\fnil MS Sans Serif;}', ''); {Skall alltid tas bort}
    text := stringreplaceall(text, '{\f1\fnil\fcharset2 Symbol;}', ''); {Skall alltid tas bort}
    text := stringreplaceall(text, '{\f2\fswiss\fprq2 System;}}', ''); {Skall alltid tas bort}
    text := stringreplaceall(text, '{\colortbl\red0\green0\blue0;}', ''); {Skall alltid tas bort}
    {I version 2.01 av Delphi finns inte \cf0 med i RTF-rutan. Tog darfor bort
    det efter \fs16 och la istallet en egen tvatt av \cf0.}
    //temptext := hamtastreng (text,'{\rtf1','\deflang');
    //text := stringreplace (text,temptext,''); {Hamta och radera allt fran start till deflang}
    text := stringreplaceall(text, '\cf0', '');
    temptext := hamtastreng(text, '\deflang', '\pard'); {Plocka fran deflang till pard for att fa }
    text := stringreplace(text, temptext, ''); {oavsett vilken lang det ar. Norska o svenska ar olika}
    {Har skall vi plocka bort fs och flera olika siffror beroende pa vilka alternativ vi godkanner.}
    //text := stringreplaceall (text,'\fs16','');{8 punkter}
    //text := stringreplaceall (text,'\fs20','');{10 punkter}
    {Nu stadar vi istallet bort alla tvasiffriga fontsize.}
    while pos('\fs', text) > 0 do

     begin
      application.processmessages;
      start := pos('\fs', text);
      Delete(text, start, 5);
     end;
    text := stringreplaceall(text, '\pard\plain\f0 ', '<P>');
    text := stringreplaceall(text, '\par \plain\f0\b\ul ', '</P><MELLIS>');
    text := stringreplaceall(text, '\plain\f0\b\ul ', '</P><MELLIS>');
    text := stringreplaceall(text, '\plain\f0', '</MELLIS>');
    text := stringreplaceall(text, '\par }', '</P>');
    text := stringreplaceall(text, '\par ', '</P><P>');
    text := stringreplaceall(text, '#]#', '}');
    text := stringreplaceall(text, '#[#', '{');
    text := stringreplaceall(text, '\\', '\');
    result := text;
    end;

    //Нижеприведенный кусок кода вырезан из довольно большой программы, вызывающей вышеприведенную функцию.
    //Я знаю что мог бы использовать потоки вместо использования отдельного файла, но у меня не было времени для реализации этого


    utfilnamn := mditted.exepath + stringreplace(stringreplace(extractfilename(pathname), '.TTT', ''), '.ttt', '') + 'ut.RTF';
    brodtext.lines.savetofile(utfilnamn);
    temptext := '';
    assignfile(tempF, utfilnamn);
    reset(tempF);
    try
    while not eof(tempF) do
     begin
      readln(tempF, temptext2);
      temptext2 := stringreplaceall(temptext2, '\' + chr(39) + 'b6', '');
      temptext2 := rtf2sgml(temptext2);
      if temptext2 <> '' then temptext := temptext + temptext2;
      application.processmessages;
     end;
    finally
    closefile(tempF);
    end;
    deletefile(utfilnamn);
    temptext := stringreplaceall(temptext, '</MELLIS> ', '</MELLIS>');
    temptext := stringreplaceall(temptext, '</P> ', '</P>');
    temptext := stringreplaceall(temptext, '</P>' + chr(0), '</P>');
    temptext := stringreplaceall(temptext, '</MELLIS></P>', '</MELLIS>');
    temptext := stringreplaceall(temptext, '<P></P>', '');
    temptext := stringreplaceall(temptext, '</P><P></MELLIS>', '</MELLIS><P>');
    temptext := stringreplaceall(temptext, '</MELLIS>', '<#MELLIS><P>');
    temptext := stringreplaceall(temptext, '<#MELLIS>', '</MELLIS>');
    temptext := stringreplaceall(temptext, '<P><P>', '<P>');
    temptext := stringreplaceall(temptext, '<P> ', '<P>');
    temptext := stringreplaceall(temptext, '<P>-', '<P>_');
    temptext := stringreplaceall(temptext, '<P>_', '<CITAT>_');
    while pos('<CITAT>_', temptext) > 0 do
    begin
     application.processmessages;
     temptext2 := hamtastreng(temptext, '<CITAT>_', '</P>');
     temptext := stringreplace(temptext, temptext2 + '</P>', temptext2 + '</CITAT>');
     temptext := stringreplace(temptext, '<CITAT>_', '<CITAT>-');
    end;
    writeln(F, '<BRODTEXT>' + temptext + '</BRODTEXT>');
    HTML --> RTF
    Код (Text):
    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;
     
  3. fishMD

    fishMD Гость

    Спасиб, но я этот пример видел... В том то и дело что
     
  4. Barmutik

    Barmutik Гость

    А не подойдёт вариант с конвертацией через MS Word ... понятно что немного кривовато... но на безрыбье и рак рыба...

    Я думаю что прямого конвертера Вы врядли найдёте ... это нам полностью парсить RTF что не тревиально...
     
  5. Barmutik

    Barmutik Гость

    А подходит ли идея использования стороннего продукта?

    В инете много конвертеров типа RTF-2-HTML 5.6.5 ... конечно официально они дорогие... но если Вас не смущает ломанная версия то наши китайские товарищи ждут Вас ... всего несколько строчек кода для работы с такими компонентами...
     
  6. fishMD

    fishMD Гость

    Пасиб за напутствие
     
Загрузка...
Статус темы:
Закрыта.

Поделиться этой страницей