Html2rft And Rtf2html

fishMD · 20.07.2005

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

Poseidon · 20.07.2005

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;

fishMD · 20.07.2005

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

Она не формирует полный HTML-аналог

Barmutik · 20.07.2005

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

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

Barmutik · 20.07.2005

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

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

fishMD · 21.07.2005

Пасиб за напутствие

Все сервисы Codeby

Поиск

Поиск

Html2rft And Rtf2html

fishMD

Poseidon

fishMD

Barmutik

Barmutik

fishMD