Html2rft And Rtf2html

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

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

    fishMD Гость

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

    Poseidon Гость

    Репутация:
    0
    RTF-->HTML
    Код:
    Приведу программу, которую я использую для преобразования содержимого 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
    Код:
    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 Гость

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

    Barmutik Гость

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

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

    Barmutik Гость

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

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

    fishMD Гость

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

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