david
0d4cc87c6c
git-svn-id: https://192.168.0.254/svn/Proyectos.Tecsitel_FactuGES2/trunk@489 0c75b7a4-871f-7646-8a2f-f78d34cc349f
583 lines
22 KiB
ObjectPascal
583 lines
22 KiB
ObjectPascal
{*************************************************************}
|
||
{ 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.
|
||
|