Tecsitel_FactuGES2/Source/Base/Utiles/Ctltortf.pas

{*************************************************************}
{          Delphi Control to RTF Conversion VCL               }
{ Version:   1.0                                              }
{ Author:    K. Nishita                                       }
{ E-Mail:    info@nishita.com                                 }
{ Home Page: http://nishita.com                               }
{ Created:   3/1/2000                                         }
{ Type:      Freeware                                         }
{ Legal:     Copyright (c) 1999 by K. Nishita                 }
{*************************************************************}
{ This component convert Delphi grid, edit, listbox, memo,    }
{ and label to Rich Text Format.                              }
{*************************************************************}
{ Please see example program for more information.            }
{*************************************************************}
{                     IMPORTANT NOTE:                         }
{ This software is provided 'as-is', without any express or   }
{ implied warranty. In no event will the author be held       }
{ liable for any damages arising from the use of this         }
{ software.                                                   }
{ Permission is granted to anyone to use this software for    }
{ any purpose, including commercial applications, and to      }
{ alter it and redistribute it freely, subject to the         }
{ following restrictions:                                     }
{ 1. The origin of this software must not be misrepresented,  }
{    you must not claim that you wrote the original software. }
{    If you use this software in a product, an acknowledgment }
{    in the product documentation would be appreciated but is }
{    not required.                                            }
{ 2. Altered source versions must be plainly marked as such,  }
{    and must not be misrepresented as being the original     }
{    software.                                                }
{ 3. This notice may not be removed or altered from any       }
{    source distribution.                                     }
{ 4. You must register this software by visiting              }
{    http://nishita.com.                                      }
{*************************************************************}

unit CtlToRTF;

interface

uses
   SysUtils, {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF} Messages, Classes, Graphics, Controls,
   StdCtrls, ExtCtrls, Grids, Forms, cxGridTableView;
   
type
   TCtrlToRTF = class(TComponent)
   private
      { Private declarations }
      RTF: TMemoryStream;
      FontTable: TStringList;
      procedure StreamWriteStr(var ms: TMemoryStream; s: string);
      function GetRTFFontTableName(FontName: string): string;
      function GetRTFFontAttrib(Style: TFontStyles): string;
      function GetRTFFontSize(Size: Integer): string;
      function GetRTFAlignment(Alignment: TAlignment): string;
      function GetRTFFontColorTableName(Color: TColor): string;
      function GetRTF: String;
      
   protected
      { Protected declarations }
   public
      { Public declarations }
      constructor Create(AOwner: TComponent); override;
      destructor Destroy; override;
      procedure CreateRTFHeader;
      procedure AddFontToTable(Font: TFont);
      procedure ImageToRTF(Image: TImage; Alignment: TAlignment);
      procedure MemoToRTF(Memo: TMemo);
      procedure ListBoxToRTF(pList: TListBox);
      procedure StringListToRTF(pStringList: TStringList; Font: TFont; Alignment: TAlignment);
      procedure StringToRTF(pString: String; Font: TFont; Alignment: TAlignment);
      procedure TextBufToRTF(TextBuf: pointer; size: word; Font: TFont; Alignment: TAlignment);
      procedure LabelToRTF(pLabel: TLabel);
      procedure EditToRTF(pEdit: TEdit);
      procedure GridToRTF(Grid: TStringGrid);
      procedure cxGridViewToRTF(cxGridView: TcxGridTableView);
      procedure SaveToFile(pFileName: String);
   published
      property RTFText: String read GetRTF;
   end;
      
      procedure Register;
      
implementation

//{$IFDEF WIN32}
// {$R *.D32}
//{$ELSE}
// {$R *.D16}
//{$ENDIF}

constructor TCtrlToRTF.Create(AOwner: TComponent);
begin
   inherited Create(AOwner);
   RTF := TMemoryStream.Create;
   FontTable := TStringList.Create;
end;

destructor TCtrlToRTF.Destroy;
begin
   RTF.Free;
   FontTable.Free;
   inherited Destroy;
end;

procedure TCtrlToRTF.CreateRTFHeader;
var i: Integer;
begin
   StreamWriteStr(RTF, '{\rtf1\ansi\ansicpg1252\deff0\deftab720');
   StreamWriteStr(RTF, '{\fonttbl');
   for i := 0 to FontTable.count - 1 do
      StreamWriteStr(RTF, FontTable.Strings[i]);
   StreamWriteStr(RTF, '}');
   StreamWriteStr(RTF, '{\colortbl');
   StreamWriteStr(RTF, '\red0\green0\blue0;');     {Black}
   StreamWriteStr(RTF, '\red128\green0\blue0;');   {Maroon}
   StreamWriteStr(RTF, '\red0\green128\blue0;');  {Green}
   StreamWriteStr(RTF, '\red128\green128\blue0;');  {Olive}
   StreamWriteStr(RTF, '\red0\green0\blue128;');   {Navy}
   StreamWriteStr(RTF, '\red128\green0\blue128;');  {Purple}
   StreamWriteStr(RTF, '\red0\green128\blue128;');  {Teal}
   StreamWriteStr(RTF, '\red128\green128\blue128;'); {Gray}
   StreamWriteStr(RTF, '\red192\green192\blue192;'); {Silver}
   StreamWriteStr(RTF, '\red255\green0\blue0;');   {Red}
   StreamWriteStr(RTF, '\red0\green255\blue0;');   {Lime}
   StreamWriteStr(RTF, '\red255\green255\blue0;');   {Yellow}
   StreamWriteStr(RTF, '\red0\green0\blue255;');     {Blue}
   StreamWriteStr(RTF, '\red255\green0\blue255;');  {Fuchsia}
   StreamWriteStr(RTF, '\red0\green255\blue255;');   {Aqua}
   StreamWriteStr(RTF, '\red255\green255\blue255;'); {White}
   StreamWriteStr(RTF, '}');
end;

procedure TCtrlToRTF.cxGridViewToRTF(cxGridView: TcxGridTableView);
var i, j: Integer;
   Temp: double;
   FontColor, FontAttrib, FontSize, FontName: String;
begin
   {FontColor:=GetRTFFontColorTableName(cxGridView.Font.Color);
   FontSize:=GetRTFFontSize(cxGridView.Font.Size);
   FontAttrib:=GetRTFFontAttrib(cxGridView.Font.Style);
   FontName:=GetRTFFontTableName(cxGridView.Font.Name);}

   CreateRTFHeader;

   FontColor := GetRTFFontColorTableName(Windows.GetSysColor(COLOR_BTNTEXT));
   FontSize := GetRTFFontSize(8);
   FontAttrib := GetRTFFontAttrib([]);
   FontName := GetRTFFontTableName('Tahoma');


   StreamWriteStr(RTF, '\par \pard\plain\cgrid');
   StreamWriteStr(RTF, '{\stylesheet{\nowidctlpar\widctlpar\adjustright \fs20\cgrid \snext0 Normal;}');
   StreamWriteStr(RTF, '{\*\cs10 \additive Default Paragraph Font;}}');
   StreamWriteStr(RTF, '{\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang{\pntxta');
   StreamWriteStr(RTF, '.}}{\*\pnseclvl2\pnucltr\pnstart1\pnindent720\pnhang');
   StreamWriteStr(RTF, '{\pntxta .}}{\*\pnseclvl3\pndec\pnstart1' + '\pnindent720\pnhang{\pntxta');
   StreamWriteStr(RTF, '.}}{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang{\pntxta');
   StreamWriteStr(RTF, ')}}{\*\pnseclvl5\pndec\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta');
   StreamWriteStr(RTF, ')}}{\*\pnseclvl6\pnlcltr\pnstart1\pnindent720\pnhang');
   StreamWriteStr(RTF, '{\pntxtb (}{\pntxta )}}{\*\pnseclvl7\pnlcrm\pnstart1\pnindent720' +
   '\pnhang{\pntxtb (}{\pntxta');
   StreamWriteStr(RTF, ')}}{\*\pnseclvl8\pnlcltr\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta');
   StreamWriteStr(RTF, ')}}{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}');

   for i := 0 to cxGridView.Controller.SelectedRowCount - 1 do
   begin
      StreamWriteStr(RTF, '\trowd');
      StreamWriteStr(RTF, '\trgaph108');
      StreamWriteStr(RTF, '\trrh260');
      StreamWriteStr(RTF, '\trleft90');
      StreamWriteStr(RTF, '\trbrdrt\brdrs\brdrw10');
      StreamWriteStr(RTF, '\trbrdrl\brdrs\brdrw10');
      StreamWriteStr(RTF, '\trbrdrb\brdrs\brdrw10');
      StreamWriteStr(RTF, '\trbrdrr\brdrs\brdrw10');
      StreamWriteStr(RTF, '\trbrdrh\brdrs\brdrw10');
      StreamWriteStr(RTF, '\trbrdrv\brdrs\brdrw10');

      for j := 0 to cxGridView.VisibleColumnCount - 1 do
      begin
         StreamWriteStr(RTF, '\clvertalt');
         StreamWriteStr(RTF, '\clbrdrt\brdrs\brdrw10');
         StreamWriteStr(RTF, '\clbrdrl\brdrs\brdrw10');
         StreamWriteStr(RTF, '\clbrdrb\brdrs\brdrw10');
         StreamWriteStr(RTF, '\clbrdrr\brdrs\brdrw10');
         // <20><><EFBFBD><EFBFBD><EFBFBD>  if (j<cxGridView.FixedCols) or (i<cxGridView.FixedRows) then StreamWriteStr(RTF,'\clcbpat8');

         {if (j=0) or (i=0) then StreamWriteStr(RTF,'\clshdng1500');}

         StreamWriteStr(RTF, '\cltxlrtb');
         Temp := (j + 1) * cxGridView.VisibleColumns[j].Width;
         Temp := (Temp / Screen.pixelsperinch) * 1440.0 + 108.0;
         StreamWriteStr(RTF, '\cellx' + IntToStr(round(Temp)));
      end;

      StreamWriteStr(RTF, '\pard\ri-123\nowidctlpar\widctlpar\intbl\adjustright');
      StreamWriteStr(RTF, ' {' + FontName + FontSize + FontAttrib + FontColor + '\cgrid0');

      for j := 0 to cxGridView.VisibleColumnCount - 1 do
         StreamWriteStr(RTF, cxGridView.DataController.DisplayTexts[cxGridView.Controller.SelectedRows[i].RecordIndex, cxGridView.VisibleColumns[j].Index] + '\cell ');
      StreamWriteStr(RTF, '}');
      StreamWriteStr(RTF, '\pard \nowidctlpar\widctlpar\intbl\adjustright {\row}');
   end;

   StreamWriteStr(RTF, '\pard\nowidctlpar\widctlpar\adjustright {');
end;

procedure TCtrlToRTF.GridToRTF(Grid: TStringGrid);
var i, j: Integer;
   Temp: double;
   FontColor, FontAttrib, FontSize, FontName: String;
begin
   FontColor := GetRTFFontColorTableName(Grid.Font.Color);
   FontSize := GetRTFFontSize(Grid.Font.Size);
   FontAttrib := GetRTFFontAttrib(Grid.Font.Style);
   FontName := GetRTFFontTableName(Grid.Font.Name);
   StreamWriteStr(RTF, '\par \pard\plain\cgrid');
   StreamWriteStr(RTF, '{\stylesheet{\nowidctlpar\widctlpar\adjustright \fs20\cgrid \snext0 Normal;}');
   StreamWriteStr(RTF, '{\*\cs10 \additive Default Paragraph Font;}}');
   StreamWriteStr(RTF, '{\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang{\pntxta');
   StreamWriteStr(RTF, '.}}{\*\pnseclvl2\pnucltr\pnstart1\pnindent720\pnhang');
   StreamWriteStr(RTF, '{\pntxta .}}{\*\pnseclvl3\pndec\pnstart1' + '\pnindent720\pnhang{\pntxta');
   StreamWriteStr(RTF, '.}}{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang{\pntxta');
   StreamWriteStr(RTF, ')}}{\*\pnseclvl5\pndec\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta');
   StreamWriteStr(RTF, ')}}{\*\pnseclvl6\pnlcltr\pnstart1\pnindent720\pnhang');
   StreamWriteStr(RTF, '{\pntxtb (}{\pntxta )}}{\*\pnseclvl7\pnlcrm\pnstart1\pnindent720' +
   '\pnhang{\pntxtb (}{\pntxta');
   StreamWriteStr(RTF, ')}}{\*\pnseclvl8\pnlcltr\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta');
   StreamWriteStr(RTF, ')}}{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}');

   for i := 0 to Grid.RowCount - 1 do
   begin
      StreamWriteStr(RTF, '\trowd');
      StreamWriteStr(RTF, '\trgaph108');
      StreamWriteStr(RTF, '\trrh260');
      StreamWriteStr(RTF, '\trleft90');
      StreamWriteStr(RTF, '\trbrdrt\brdrs\brdrw10');
      StreamWriteStr(RTF, '\trbrdrl\brdrs\brdrw10');
      StreamWriteStr(RTF, '\trbrdrb\brdrs\brdrw10');
      StreamWriteStr(RTF, '\trbrdrr\brdrs\brdrw10');
      StreamWriteStr(RTF, '\trbrdrh\brdrs\brdrw10');
      StreamWriteStr(RTF, '\trbrdrv\brdrs\brdrw10');

      for j := 0 to Grid.ColCount - 1 do
      begin
         StreamWriteStr(RTF, '\clvertalt');
         StreamWriteStr(RTF, '\clbrdrt\brdrs\brdrw10');
         StreamWriteStr(RTF, '\clbrdrl\brdrs\brdrw10');
         StreamWriteStr(RTF, '\clbrdrb\brdrs\brdrw10');
         StreamWriteStr(RTF, '\clbrdrr\brdrs\brdrw10');
         if (j<Grid.FixedCols) or (i<Grid.FixedRows) then StreamWriteStr(RTF, '\clcbpat8');
         {if (j=0) or (i=0) then StreamWriteStr(RTF,'\clshdng1500');}
         StreamWriteStr(RTF, '\cltxlrtb');
         Temp := (j + 1) * Grid.DefaultColWidth;
         Temp := (Temp / Screen.pixelsperinch) * 1440.0 + 108.0;
         StreamWriteStr(RTF, '\cellx' + IntToStr(round(Temp)));
      end;
      StreamWriteStr(RTF, '\pard\ri-123\nowidctlpar\widctlpar\intbl\adjustright');
      StreamWriteStr(RTF, ' {' + FontName + FontSize + FontAttrib + FontColor + '\cgrid0');
      for j := 0 to Grid.ColCount - 1 do
         StreamWriteStr(RTF, Grid.Cells[j, i] + '\cell ');
      StreamWriteStr(RTF, '}');
      StreamWriteStr(RTF, '\pard \nowidctlpar\widctlpar\intbl\adjustright {\row}');
   end;

   StreamWriteStr(RTF, '\pard\nowidctlpar\widctlpar\adjustright {');
end;


procedure TCtrlToRTF.ImageToRTF(Image: TImage; Alignment: TAlignment);
  type
    PtrRec = record
              Lo: Word;
              Hi: Word;
             end;

    PHugeByteArray = ^THugeByteArray;
    THugeByteArray = array[0..0] of Byte;

  function GetBigPointer(lp: pointer; Offset: LongInt): Pointer;
  begin
     {$IFDEF WIN32}
     GetBigPointer := @PHugeByteArray(lp)^[Offset];
     {$ELSE}
     Offset := Offset + PTRREC(lp).Lo;
     GetBigPointer := Ptr(PtrRec(lp).Hi + PtrRec(Offset).Hi * SelectorInc, PtrRec(Offset).Lo);
     {$ENDIF}
  end;

var
   hmf: THandle;
   FCanvas: TCanvas;
   lpBits: pointer;
   dwSize: LongInt;
   h, h1, w, w1: double;
   Align: string;
   pPPoint: PPoint;
   pPSize: PSize;
begin
   dwSize := 0;

   FCanvas := TCanvas.Create;
   FCanvas.Handle := CreateMetafile(nil);
   SetMapMode(FCanvas.Handle, mm_AnIsoTropic);
   {$IFDEF WIN32}
   SetWindowOrgEx(FCanvas.Handle, 0, 0, pPPoint);
   SetWindowExtEx(FCanvas.Handle, Image.Width, Image.Height, pPSize);
   {$ELSE}
   SetWindowOrg(FCanvas.Handle, 0, 0);
   SetWindowExt(FCanvas.Handle, Image.Width, Image.Height);
   {$ENDIF}
   FCanvas.StretchDraw(rect(0, 0, Image.Width, Image.Height), Image.Picture.Graphic);
   hmf := CloseMetafile(FCanvas.Handle);
   {$IFDEF WIN32}
   dwSize := GetMetaFileBitsEx(hmf, dwSize, nil);
   GetMem(lpBits, dwSize);
   GetMetaFileBitsEx(hmf, dwSize, lpBits);
   {$ELSE}
   hGlobal := GetMetaFileBits( hmf );
   dwSize := GlobalSize(hGlobal);
   lpBits := GlobalLock( hGlobal );
   {$ENDIF}
   h := Image.Height;
   h1 := h;
   w := Image.Width;
   w1 := w;
   h := (h / Screen.pixelsperinch) * 1440.0;
   w := (w / Screen.pixelsperinch) * 1440.0;
   h1 := 26.46875 * h1;
   w1 := 26.46875 * w1;
   Align := GetRTFAlignment(Alignment);
   StreamWriteStr(RTF, '\par \pard' + Align + '\plain\cgrid {\pict');
   StreamWriteStr(RTF, '\picscalex100');
   StreamWriteStr(RTF, '\picscaley100');
   StreamWriteStr(RTF, '\piccropl0');
   StreamWriteStr(RTF, '\piccropr0');
   StreamWriteStr(RTF, '\piccropt0');
   StreamWriteStr(RTF, '\piccropb0');
   StreamWriteStr(RTF, '\picw' + inttostr(round(w1)));
   StreamWriteStr(RTF, '\pich' + inttostr(round(h1)));
   StreamWriteStr(RTF, '\picwgoal' + inttostr(round(w)));
   StreamWriteStr(RTF, '\pichgoal' + inttostr(round(h)));
   StreamWriteStr(RTF, '\wmetafile8 \bin' + IntToStr(dwSize));
   RTF.Write(lpBits^, dwSize);
   {$IFDEF WIN32}
   FreeMem(lpBits);
   {$ELSE}
   GlobalUnLock( hGlobal );
   {$ENDIF}
   StreamWriteStr(RTF, '}');
   DeleteMetaFile(hmf);
   FCanvas.Free;
end;

procedure TCtrlToRTF.MemoToRTF(Memo: TMemo);
var i: Integer;
   Align, FontColor, FontAttrib, FontSize, FontName: String;
begin
   Align := GetRTFAlignment(Memo.Alignment);
   FontColor := GetRTFFontColorTableName(Memo.Font.Color);
   FontSize := GetRTFFontSize(Memo.Font.Size);
   FontAttrib := GetRTFFontAttrib(Memo.Font.Style);
   FontName := GetRTFFontTableName(Memo.Font.Name);
   StreamWriteStr(RTF, '\par \pard' + Align + '\plain' + FontName + FontSize + FontAttrib + FontColor);
   for i := 0 to Memo.Lines.Count - 1 do
   begin
      StreamWriteStr(RTF, ' \par ' + Memo.Lines[i]);
   end;
end;

procedure TCtrlToRTF.LabelToRTF(pLabel: TLabel);
var
  Align, FontColor, FontAttrib, FontSize, FontName: String;
begin
   Align := GetRTFAlignment(pLabel.Alignment);
   FontColor := GetRTFFontColorTableName(pLabel.Font.Color);
   FontSize := GetRTFFontSize(pLabel.Font.Size);
   FontAttrib := GetRTFFontAttrib(pLabel.Font.Style);
   FontName := GetRTFFontTableName(pLabel.Font.Name);
   StreamWriteStr(RTF, '\par \pard' + Align + '\plain' + FontName + FontSize + FontAttrib + FontColor + ' ' + pLabel.Caption);
end;

procedure TCtrlToRTF.TextBufToRTF(TextBuf: pointer; size: word; Font: TFont; Alignment: TAlignment);
var
   Align, FontColor, FontAttrib, FontSize, FontName: String;
begin
   Align := GetRTFAlignment(Alignment);
   FontColor := GetRTFFontColorTableName(Font.Color);
   FontSize := GetRTFFontSize(Font.Size);
   FontAttrib := GetRTFFontAttrib(Font.Style);
   FontName := GetRTFFontTableName(Font.Name);
   StreamWriteStr(RTF, '\par \pard' + Align + '\plain' + FontName + FontSize + FontAttrib + FontColor + ' \par');
   RTF.Write(TextBuf^, size);
end;

procedure TCtrlToRTF.ListBoxToRTF(pList: TListBox);
var i: Integer;
   FontColor, FontAttrib, FontSize, FontName: String;
begin
   FontColor := GetRTFFontColorTableName(pList.Font.Color);
   FontSize := GetRTFFontSize(pList.Font.Size);
   FontAttrib := GetRTFFontAttrib(pList.Font.Style);
   FontName := GetRTFFontTableName(pList.Font.Name);
   StreamWriteStr(RTF, '\par \pard\plain' + FontName + FontSize + FontAttrib + FontColor);
   for i := 0 to pList.Items.Count - 1 do
   begin
      StreamWriteStr(RTF, ' \par ' + pList.Items[i]);
   end;
end;

procedure TCtrlToRTF.StringListToRTF(pStringList: TStringList; Font: TFont; Alignment: TAlignment);
var i: Integer;
   Align, FontColor, FontAttrib, FontSize, FontName: String;
begin
   Align := GetRTFAlignment(Alignment);
   FontColor := GetRTFFontColorTableName(Font.Color);
   FontSize := GetRTFFontSize(Font.Size);
   FontAttrib := GetRTFFontAttrib(Font.Style);
   FontName := GetRTFFontTableName(Font.Name);
   StreamWriteStr(RTF, '\par \pard' + Align + '\plain' + FontName + FontSize + FontAttrib + FontColor);
   for i := 0 to pStringList.Count - 1 do
   begin
      StreamWriteStr(RTF, ' \par ' + pStringList.strings[i]);
   end;
end;

procedure TCtrlToRTF.StringToRTF(pString: String; Font: TFont; Alignment: TAlignment);
var Align, FontColor, FontAttrib, FontSize, FontName: String;
begin
   Align := GetRTFAlignment(Alignment);
   FontColor := GetRTFFontColorTableName(Font.Color);
   FontSize := GetRTFFontSize(Font.Size);
   FontAttrib := GetRTFFontAttrib(Font.Style);
   FontName := GetRTFFontTableName(Font.Name);
   StreamWriteStr(RTF, '\par \pard' + Align + '\plain' + FontName + FontSize + FontAttrib + FontColor + ' ' + pString);
end;


procedure TCtrlToRTF.EditToRTF(pEdit: TEdit);
begin
   StringToRTF(pEdit.Text, pEdit.Font, taLeftJustify);
end;


function TCtrlToRTF.GetRTFFontTableName(FontName: string): string;
var i: Integer;
begin
   Result := '\f0';
   for i := 0 to FontTable.Count - 1 do
   begin
      if Pos(FontName, FontTable.Strings[i]) > 0 then
      begin
         Result := '\f' + IntToStr(i);
         Exit;
      end;
   end;
end;

function TCtrlToRTF.GetRTFFontAttrib(Style: TFontStyles): string;
var retval: string;
begin
   retval := '';
   if fsBold in Style then
      retval := retval + '\b';
   if fsItalic in Style then
      retval := retval + '\c';
   if fsUnderline in Style then
      retval := retval + '\ul';
   if fsStrikeOut in Style then
      retval := retval + '\strike';
   Result := retval;
end;

function TCtrlToRTF.GetRTFFontSize(Size: Integer): string;
begin
   Result := '\fs' + IntToStr(size * 2);
end;

function TCtrlToRTF.GetRTF: String;
var
   A: TStringList;
begin
   StreamWriteStr(RTF, #13#10 + '}}');
   RTF.Position := 0;
   A := TStringList.Create;
   try
      A.LoadFromStream(RTF);
      Result := A.Text;
   finally
      FreeANDNIL(A);
   end;
end;

function TCtrlToRTF.GetRTFAlignment(Alignment: TAlignment): string;
var Align: String;
begin
   if Alignment = taCenter then Align := '\qc'
   else if Alignment = taRightJustify then Align := '\qr'
      else Align := '';
   Result := Align;
end;

function TCtrlToRTF.GetRTFFontColorTableName(Color: TColor): string;
begin
   if Color = clBlack then  Result := '\cf0'
   else if Color = clMaroon then Result := '\cf1'
      else if Color = clGreen then  Result := '\cf2'
      else if Color = clOlive then  Result := '\cf3'
      else if Color = clNavy then   Result := '\cf4'
      else if Color = clPurple then Result := '\cf5'
      else if Color = clTeal then   Result := '\cf6'
      else if Color = clGray then   Result := '\cf7'
      else if Color = clSilver then Result := '\cf8'
      else if Color = clRed then    Result := '\cf9'
      else if Color = clLime then   Result := '\cf10'
      else if Color = clYellow then Result := '\cf11'
      else if Color = clBlue then   Result := '\cf12'
      else if Color = clFuchsia then Result := '\cf13'
      else if Color = clAqua then   Result := '\cf14'
      else if Color = clWhite then  Result := '\cf15';
end;

procedure TCtrlToRTF.AddFontToTable(Font: TFont);
var  DC: HDC;
   SaveFont: HFont;
   Metrics: TTextMetric;
   Temp: byte;
   I: Integer;
   charset, family: string;
begin
   DC := GetDC(0);
   SaveFont := SelectObject(DC, Font.Handle);
   GetTextMetrics(DC, Metrics);
   SelectObject(DC, SaveFont);
   ReleaseDC(0, DC);
   for I := 0 to FontTable.Count - 1 do
   begin
      if Pos(Font.Name, FontTable.Strings[i]) > 0 then
         Exit;
   end;
   case Metrics.tmCharSet of
      ANSI_CHARSET: charset := 'fcharset0';
      DEFAULT_CHARSET: charset := 'fcharset1';
      SYMBOL_CHARSET: charset := 'fcharset2';
      SHIFTJIS_CHARSET: charset := 'fcharset128';
      OEM_CHARSET: charset := 'fcharset255';
      else charset := '';
   end;
   Temp := Metrics.tmPitchAndFamily;
   Temp := (Temp shr 4) shl 4;
   case Temp of
      FF_DECORATIVE: family := 'fdecorative';
      FF_DONTCARE: family := 'fdontcare';
      FF_MODERN: family := 'fmodern';
      FF_ROMAN: family := 'froman';
      FF_SCRIPT: family := 'fscript';
      FF_SWISS: family := 'fswiss';
      else family := 'froman';
   end;
   FontTable.Add('{\f' + IntToStr(FontTable.Count) + '\' + family + '\' + charset + ' ' + font.name + ';}');
end;

procedure TCtrlToRTF.SaveToFile(pFileName: String);
begin
   StreamWriteStr(RTF, #13#10 + '}}');
   RTF.SaveToFile(pFileName);
end;

procedure TCtrlToRTF.StreamWriteStr(var ms: TMemoryStream; s: string);
begin
   ms.Write(s[1], Length(s));
end;

procedure Register;
begin
   RegisterComponents('CynapSYS', [TCtrlToRTF]);
end;

end.