| Конвертация RTF в HTML |
|
| Написал Snowy | |
| 06.09.2007 | |
|
Данный модуль конвертирует текст из RichEdit в HTML. Поддерживается только RTF 1.0 - то есть то, что поддерживается Delphi. Различные OLE объекты, типа картинок и прочие нововведения после стандарта 1.0 не поддерживаются. Единственное, что поддерживается дополнительно - определение гиперссылок. unit Rtf2Html; interface uses Windows, SysUtils, Classes, Graphics, ComCtrls, RichEdit, Forms; function TextToHtml(s: string): string; {* Конвертирует plain/text в html } implementation function TextToHtml(s: string): string; const ot = #1'<'; ct = '>'#1; function HtmlColor(Col: integer): string; begin Col := ColorToRGB(Col); Result := '#' + Format('%.2x%.2x%.2x', [GetRValue(Col), GetGValue(Col), GetBValue(Col)]); end; function IsRTF(txt: string): boolean; begin if copy(txt,1,5) = '{\rtf' then result := true else result := false; end; function HtmlChar(ch: char): string; const sim: array[1..6] of string = ('<', '>','"','&', ' ', ''); sims = '<>"&'#13#10; begin if pos(ch, sims) > 0 then result := sim[pos(ch, sims)] else result := ch; end; function DetectUrl(txt: string): string; var i,j: integer; s,l: string; h: boolean; begin result := ''; l := LowerCase(txt); h := false; i := 0; repeat inc(i); if txt[i] = #1 then h := not h; if h then result := result + txt[i] else if (copy(l, i, 7) = 'http://') or (copy(l, i, 8) = 'https://') or (copy(l, i, 6) = 'ftp://') or (copy(l, i, 4) = 'www.') then begin s := ''; for j := i to Length(l) do if pos(l[j], #1#13#10' <>') = 0 then s := s + txt[j] else Break; inc(i, Length(s)-1); result := result + ot + 'a href="'; if pos('://', s) = 0 then result := result + 'http://'; result := result + s + '"' + ct + s + ot + '/a' + ct; end else result := result + txt[i]; until i >= Length(l); end; function RtfToHtml(s: string): string; var re: TRichEdit; ss: TStringStream; f: string; i, sz, cl: integer; st: TFontStyles; al: TAlignment; n: TNumberingStyle; sp: boolean; begin result := ''; re := TRichEdit.Create(nil); re.Visible := false; re.Width := 4096; re.Height := 0; re.Parent := Application.MainForm; ss := TStringStream.Create(s); re.Lines.LoadFromStream(ss); ss.Free; s := re.Text; f := ''; sz := 0; cl := -1; st := []; sp := false; al := taLeftJustify; n := nsNone; for i := 1 to Length(s) do begin re.SelStart := i; if (re.CaretPos.X=0) and (re.Lines[re.CaretPos.Y]='') then if s[i]=#13 then result:=result+ot+'br'+ct; if re.CaretPos.X = 1 then begin // Paragraph if re.Paragraph.Alignment <> al then begin if al <> taLeftJustify then result := result + ot+'/div'+ct; al := re.Paragraph.Alignment; if al = taRightJustify then result := result + ot+'div align=right'+ct; if al = taCenter then result := result + ot+'div align=center'+ct; end else if n = nsNone then result := result + ot+'br'+ct; if n = nsBullet then result := result+ot+'/li'+ct; if (re.Paragraph.Numbering = nsBullet) and (n = nsNone) then begin result := result + ot +'ul'+ct; n := nsBullet; end; if (re.Paragraph.Numbering <> nsBullet) and (n = nsBullet) then begin result := result + ot+'/ul'+ct; n := nsNone; end; if n = nsBullet then result := result + ot+'li'+ct; end; with re.SelAttributes do // Font if (f <> Name) or (sz <> Size) or (cl <> Color) or (st <> Style) then begin if sp then begin result := result + ot+'/span'+ct; sp := false; end; if s[i] > #31 then begin f := Name; sz := Size; cl := Color; st := Style; result := result + ot+'span style="{font-family:' + f + ';font-size:' + IntToStr(sz) + 'pt;'; if cl <> 0 then result := result + 'color:' + HtmlColor(cl)+';'; if fsBold in st then result := result + 'font-weight:bold;'; if fsItalic in st then result := result + 'font-style:italic;'; if fsUnderline in st then result := result + 'text-decoration:underline;'; if fsStrikeOut in st then result := result + 'text-decoration:line-through;'; result := result + '}"'+ct; sp := true; end; end; if s[i] > #31 then result := result + s[i]; end; if sp then result := result + ot+'/span'+ct; if al <> taLeftJustify then result := result + ot+'/div'+ct; if n = nsBullet then result := result + ot+'/ul'+ct; re.Free; end; var i: integer; h: boolean; begin i := 0; result := ''; h := false; if IsRTF(s) then s := RtfToHtml(s) else result := '<font style="font-size:12pt; font-family:courier">'; s := DetectUrl(s); repeat inc(i); if s[i] = #1 then h := not h else if h then result := result + s[i] else result := result + HtmlChar(s[i]); until i = Length(s); end; end.А теперь пример использования: uses Rtf2Html; procedure TForm1.Button1Click(Sender: TObject); var sl: TStringList; ms: TMemoryStream; begin sl := TStringList.Create; try //sl.LoadFromFile('1.txt'); // можно грузить rtf или txt sl.LoadFromFile('1.rtf'); sl.Text := TextToHtml(sl.Text); //sl.SaveToFile('1.htm'); // можно сохранить результат в файл ms := TMemoryStream.Create; sl.SaveToStream(ms); ms.Position := 0; try // загрузка результата в TWebBrowser. Для краткости ему назначено имя wb wb.Navigate('about:blank'); // открываем пустую страницу while wb.ReadyState < READYSTATE_INTERACTIVE do Application.HandleMessage; // загружаем в неё наш html (wb.Document as IPersistStreamInit).Load(TStreamAdapter.Create(ms)); finally ms.Free; end; finally sl.Free; end; end;Пример грузит RTF из файла 1.rtf и отображает сконвертированный вариант в TWebBrowser с именем wb. |
illy:' />| < Пред. | След. > |
|---|