DelphiLab - Конвертация RTF в HTML

Конвертация 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;