{*************************************************************}
{          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 }
  FFileName:string;
  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');
    // żżżżż  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,hGlobal:THandle;
i,j: integer;
FCanvas : TCanvas;
lpBits:pointer;
dwSize,count:LongInt;
Ch:char;
h,h1,w,w1:double;
TempBuf:PChar;
Align:string;
pPPoint:PPoint;
pPSize:PSize;
begin
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 i:Integer;
    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 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+' \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;
     SysMetrics, 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.