Tecistel/Tecsitel_FactuGES2
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Limpieza de código y de mensajes de warning

Browse Source 
git-svn-id: https://192.168.0.254/svn/Proyectos.Tecsitel_FactuGES2/trunk@489 0c75b7a4-871f-7646-8a2f-f78d34cc349f
This commit is contained in:
David Arranz 2008-07-31 15:48:01 +00:00
parent 75215a1af9
commit 0d4cc87c6c
3 changed files with 445 additions and 530 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

887
Source/Base/Utiles/Ctltortf.pas
View File

@ -32,7 +32,7 @@
{ software. } { software. }
{ 3. This notice may not be removed or altered from any } { 3. This notice may not be removed or altered from any }
{ source distribution. } { source distribution. }
{ 4. You must register this software by visiting } { 4. You must register this software by visiting }
{ http://nishita.com. } { http://nishita.com. }
{*************************************************************} {*************************************************************}
@ -41,49 +41,48 @@ unit CtlToRTF;
interface interface
uses uses
SysUtils, {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs,{$ENDIF} Messages, Classes, Graphics, Controls, SysUtils, {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF} Messages, Classes, Graphics, Controls,
StdCtrls, ExtCtrls, Grids, Forms, cxGridTableView; StdCtrls, ExtCtrls, Grids, Forms, cxGridTableView;
type type
TCtrlToRTF = class(TComponent) TCtrlToRTF = class(TComponent)
private private
{ Private declarations } { Private declarations }
FFileName:string; RTF: TMemoryStream;
RTF:TMemoryStream; FontTable: TStringList;
FontTable:TStringList; procedure StreamWriteStr(var ms: TMemoryStream; s: string);
procedure StreamWriteStr(var ms: TMemoryStream; s: string); function GetRTFFontTableName(FontName: string): string;
function GetRTFFontTableName(FontName:string):string; function GetRTFFontAttrib(Style: TFontStyles): string;
function GetRTFFontAttrib(Style:TFontStyles):string; function GetRTFFontSize(Size: Integer): string;
function GetRTFFontSize(Size:Integer):string; function GetRTFAlignment(Alignment: TAlignment): string;
function GetRTFAlignment(Alignment:TAlignment):string; function GetRTFFontColorTableName(Color: TColor): string;
function GetRTFFontColorTableName(Color:TColor):string; function GetRTF: String;
function GetRTF: String;
protected
protected { Protected declarations }
{ Protected declarations } public
public { Public declarations }
{ Public declarations } constructor Create(AOwner: TComponent); override;
constructor Create(AOwner: TComponent); override; destructor Destroy; override;
destructor Destroy; override; procedure CreateRTFHeader;
procedure CreateRTFHeader; procedure AddFontToTable(Font: TFont);
procedure AddFontToTable(Font:TFont); procedure ImageToRTF(Image: TImage; Alignment: TAlignment);
procedure ImageToRTF(Image:TImage;Alignment:TAlignment); procedure MemoToRTF(Memo: TMemo);
procedure MemoToRTF(Memo:TMemo); procedure ListBoxToRTF(pList: TListBox);
procedure ListBoxToRTF(pList:TListBox); procedure StringListToRTF(pStringList: TStringList; Font: TFont; Alignment: TAlignment);
procedure StringListToRTF(pStringList:TStringList;Font:TFont;Alignment:TAlignment); procedure StringToRTF(pString: String; Font: TFont; Alignment: TAlignment);
procedure StringToRTF(pString:String;Font:TFont;Alignment:TAlignment); procedure TextBufToRTF(TextBuf: pointer; size: word; Font: TFont; Alignment: TAlignment);
procedure TextBufToRTF(TextBuf:pointer;size:word;Font:TFont;Alignment:TAlignment); procedure LabelToRTF(pLabel: TLabel);
procedure LabelToRTF(pLabel:TLabel); procedure EditToRTF(pEdit: TEdit);
procedure EditToRTF(pEdit:TEdit); procedure GridToRTF(Grid: TStringGrid);
procedure GridToRTF(Grid:TStringGrid); procedure cxGridViewToRTF(cxGridView: TcxGridTableView);
procedure cxGridViewToRTF(cxGridView:TcxGridTableView); procedure SaveToFile(pFileName: String);
procedure SaveToFile(pFileName:String); published
published property RTFText: String read GetRTF;
property RTFText : String read GetRTF; end;
end;
procedure Register;
procedure Register;
implementation implementation
//{$IFDEF WIN32} //{$IFDEF WIN32}
@ -94,488 +93,490 @@ implementation
constructor TCtrlToRTF.Create(AOwner: TComponent); constructor TCtrlToRTF.Create(AOwner: TComponent);
begin begin
inherited Create(AOwner); inherited Create(AOwner);
RTF:=TMemoryStream.Create; RTF := TMemoryStream.Create;
FontTable:=TStringList.Create; FontTable := TStringList.Create;
end; end;
destructor TCtrlToRTF.Destroy; destructor TCtrlToRTF.Destroy;
begin begin
RTF.Free; RTF.Free;
FontTable.Free; FontTable.Free;
inherited Destroy; inherited Destroy;
end; end;
procedure TCtrlToRTF.CreateRTFHeader; procedure TCtrlToRTF.CreateRTFHeader;
var i:Integer; var i: Integer;
begin begin
StreamWriteStr(RTF,'{\rtf1\ansi\ansicpg1252\deff0\deftab720'); StreamWriteStr(RTF, '{\rtf1\ansi\ansicpg1252\deff0\deftab720');
StreamWriteStr(RTF,'{\fonttbl'); StreamWriteStr(RTF, '{\fonttbl');
for i:=0 to FontTable.count-1 do for i := 0 to FontTable.count - 1 do
StreamWriteStr(RTF,FontTable.Strings[i]); StreamWriteStr(RTF, FontTable.Strings[i]);
StreamWriteStr(RTF,'}'); StreamWriteStr(RTF, '}');
StreamWriteStr(RTF,'{\colortbl'); StreamWriteStr(RTF, '{\colortbl');
StreamWriteStr(RTF,'\red0\green0\blue0;'); {Black} StreamWriteStr(RTF, '\red0\green0\blue0;'); {Black}
StreamWriteStr(RTF,'\red128\green0\blue0;'); {Maroon} StreamWriteStr(RTF, '\red128\green0\blue0;'); {Maroon}
StreamWriteStr(RTF,'\red0\green128\blue0;'); {Green} StreamWriteStr(RTF, '\red0\green128\blue0;'); {Green}
StreamWriteStr(RTF,'\red128\green128\blue0;'); {Olive} StreamWriteStr(RTF, '\red128\green128\blue0;'); {Olive}
StreamWriteStr(RTF,'\red0\green0\blue128;'); {Navy} StreamWriteStr(RTF, '\red0\green0\blue128;'); {Navy}
StreamWriteStr(RTF,'\red128\green0\blue128;'); {Purple} StreamWriteStr(RTF, '\red128\green0\blue128;'); {Purple}
StreamWriteStr(RTF,'\red0\green128\blue128;'); {Teal} StreamWriteStr(RTF, '\red0\green128\blue128;'); {Teal}
StreamWriteStr(RTF,'\red128\green128\blue128;'); {Gray} StreamWriteStr(RTF, '\red128\green128\blue128;'); {Gray}
StreamWriteStr(RTF,'\red192\green192\blue192;'); {Silver} StreamWriteStr(RTF, '\red192\green192\blue192;'); {Silver}
StreamWriteStr(RTF,'\red255\green0\blue0;'); {Red} StreamWriteStr(RTF, '\red255\green0\blue0;'); {Red}
StreamWriteStr(RTF,'\red0\green255\blue0;'); {Lime} StreamWriteStr(RTF, '\red0\green255\blue0;'); {Lime}
StreamWriteStr(RTF,'\red255\green255\blue0;'); {Yellow} StreamWriteStr(RTF, '\red255\green255\blue0;'); {Yellow}
StreamWriteStr(RTF,'\red0\green0\blue255;'); {Blue} StreamWriteStr(RTF, '\red0\green0\blue255;'); {Blue}
StreamWriteStr(RTF,'\red255\green0\blue255;'); {Fuchsia} StreamWriteStr(RTF, '\red255\green0\blue255;'); {Fuchsia}
StreamWriteStr(RTF,'\red0\green255\blue255;'); {Aqua} StreamWriteStr(RTF, '\red0\green255\blue255;'); {Aqua}
StreamWriteStr(RTF,'\red255\green255\blue255;'); {White} StreamWriteStr(RTF, '\red255\green255\blue255;'); {White}
StreamWriteStr(RTF,'}'); StreamWriteStr(RTF, '}');
end; end;
procedure TCtrlToRTF.cxGridViewToRTF(cxGridView: TcxGridTableView); procedure TCtrlToRTF.cxGridViewToRTF(cxGridView: TcxGridTableView);
var i,j:Integer; var i, j: Integer;
Temp:double; Temp: double;
FontColor,FontAttrib,FontSize,FontName:String; FontColor, FontAttrib, FontSize, FontName: String;
begin begin
{FontColor:=GetRTFFontColorTableName(cxGridView.Font.Color); {FontColor:=GetRTFFontColorTableName(cxGridView.Font.Color);
FontSize:=GetRTFFontSize(cxGridView.Font.Size); FontSize:=GetRTFFontSize(cxGridView.Font.Size);
FontAttrib:=GetRTFFontAttrib(cxGridView.Font.Style); FontAttrib:=GetRTFFontAttrib(cxGridView.Font.Style);
FontName:=GetRTFFontTableName(cxGridView.Font.Name);} FontName:=GetRTFFontTableName(cxGridView.Font.Name);}
CreateRTFHeader; CreateRTFHeader;
FontColor:=GetRTFFontColorTableName(Windows.GetSysColor(COLOR_BTNTEXT)); FontColor := GetRTFFontColorTableName(Windows.GetSysColor(COLOR_BTNTEXT));
FontSize:=GetRTFFontSize(8); FontSize := GetRTFFontSize(8);
FontAttrib:=GetRTFFontAttrib([]); FontAttrib := GetRTFFontAttrib([]);
FontName:=GetRTFFontTableName('Tahoma'); FontName := GetRTFFontTableName('Tahoma');
StreamWriteStr(RTF,'\par \pard\plain\cgrid'); StreamWriteStr(RTF, '\par \pard\plain\cgrid');
StreamWriteStr(RTF,'{\stylesheet{\nowidctlpar\widctlpar\adjustright \fs20\cgrid \snext0 Normal;}'); StreamWriteStr(RTF, '{\stylesheet{\nowidctlpar\widctlpar\adjustright \fs20\cgrid \snext0 Normal;}');
StreamWriteStr(RTF,'{\*\cs10 \additive Default Paragraph Font;}}'); StreamWriteStr(RTF, '{\*\cs10 \additive Default Paragraph Font;}}');
StreamWriteStr(RTF,'{\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang{\pntxta'); StreamWriteStr(RTF, '{\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang{\pntxta');
StreamWriteStr(RTF,'.}}{\*\pnseclvl2\pnucltr\pnstart1\pnindent720\pnhang'); StreamWriteStr(RTF, '.}}{\*\pnseclvl2\pnucltr\pnstart1\pnindent720\pnhang');
StreamWriteStr(RTF,'{\pntxta .}}{\*\pnseclvl3\pndec\pnstart1'+'\pnindent720\pnhang{\pntxta'); StreamWriteStr(RTF, '{\pntxta .}}{\*\pnseclvl3\pndec\pnstart1' + '\pnindent720\pnhang{\pntxta');
StreamWriteStr(RTF,'.}}{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang{\pntxta'); StreamWriteStr(RTF, '.}}{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang{\pntxta');
StreamWriteStr(RTF,')}}{\*\pnseclvl5\pndec\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta'); StreamWriteStr(RTF, ')}}{\*\pnseclvl5\pndec\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta');
StreamWriteStr(RTF,')}}{\*\pnseclvl6\pnlcltr\pnstart1\pnindent720\pnhang'); StreamWriteStr(RTF, ')}}{\*\pnseclvl6\pnlcltr\pnstart1\pnindent720\pnhang');
StreamWriteStr(RTF,'{\pntxtb (}{\pntxta )}}{\*\pnseclvl7\pnlcrm\pnstart1\pnindent720'+ StreamWriteStr(RTF, '{\pntxtb (}{\pntxta )}}{\*\pnseclvl7\pnlcrm\pnstart1\pnindent720' +
'\pnhang{\pntxtb (}{\pntxta'); '\pnhang{\pntxtb (}{\pntxta');
StreamWriteStr(RTF,')}}{\*\pnseclvl8\pnlcltr\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta'); StreamWriteStr(RTF, ')}}{\*\pnseclvl8\pnlcltr\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta');
StreamWriteStr(RTF,')}}{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}'); StreamWriteStr(RTF, ')}}{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}');
for i:=0 to cxGridView.Controller.SelectedRowCount-1 do 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 begin
StreamWriteStr(RTF,'\trowd'); FontColor := GetRTFFontColorTableName(Grid.Font.Color);
StreamWriteStr(RTF,'\trgaph108'); FontSize := GetRTFFontSize(Grid.Font.Size);
StreamWriteStr(RTF,'\trrh260'); FontAttrib := GetRTFFontAttrib(Grid.Font.Style);
StreamWriteStr(RTF,'\trleft90'); FontName := GetRTFFontTableName(Grid.Font.Name);
StreamWriteStr(RTF,'\trbrdrt\brdrs\brdrw10'); StreamWriteStr(RTF, '\par \pard\plain\cgrid');
StreamWriteStr(RTF,'\trbrdrl\brdrs\brdrw10'); StreamWriteStr(RTF, '{\stylesheet{\nowidctlpar\widctlpar\adjustright \fs20\cgrid \snext0 Normal;}');
StreamWriteStr(RTF,'\trbrdrb\brdrs\brdrw10'); StreamWriteStr(RTF, '{\*\cs10 \additive Default Paragraph Font;}}');
StreamWriteStr(RTF,'\trbrdrr\brdrs\brdrw10'); StreamWriteStr(RTF, '{\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang{\pntxta');
StreamWriteStr(RTF,'\trbrdrh\brdrs\brdrw10'); StreamWriteStr(RTF, '.}}{\*\pnseclvl2\pnucltr\pnstart1\pnindent720\pnhang');
StreamWriteStr(RTF,'\trbrdrv\brdrs\brdrw10'); 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 j:=0 to cxGridView.VisibleColumnCount-1 do 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 begin
StreamWriteStr(RTF,'\clvertalt'); {$IFDEF WIN32}
StreamWriteStr(RTF,'\clbrdrt\brdrs\brdrw10'); GetBigPointer := @PHugeByteArray(lp)^[Offset];
StreamWriteStr(RTF,'\clbrdrl\brdrs\brdrw10'); {$ELSE}
StreamWriteStr(RTF,'\clbrdrb\brdrs\brdrw10'); Offset := Offset + PTRREC(lp).Lo;
StreamWriteStr(RTF,'\clbrdrr\brdrs\brdrw10'); GetBigPointer := Ptr(PtrRec(lp).Hi + PtrRec(Offset).Hi * SelectorInc, PtrRec(Offset).Lo);
// ¿¿¿¿¿ if (j<cxGridView.FixedCols) or (i<cxGridView.FixedRows) then StreamWriteStr(RTF,'\clcbpat8'); {$ENDIF}
{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; 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 var
hmf,hGlobal:THandle; hmf: THandle;
i,j: integer; FCanvas: TCanvas;
FCanvas : TCanvas; lpBits: pointer;
lpBits:pointer; dwSize: LongInt;
dwSize,count:LongInt; h, h1, w, w1: double;
Ch:char; Align: string;
h,h1,w,w1:double; pPPoint: PPoint;
TempBuf:PChar; pPSize: PSize;
Align:string;
pPPoint:PPoint;
pPSize:PSize;
begin begin
FCanvas := TCanvas.Create; dwSize := 0;
FCanvas.Handle := CreateMetafile(nil);
SetMapMode(FCanvas.Handle, mm_AnIsoTropic); FCanvas := TCanvas.Create;
{$IFDEF WIN32} FCanvas.Handle := CreateMetafile(nil);
SetWindowOrgEx(FCanvas.Handle, 0, 0, pPPoint); SetMapMode(FCanvas.Handle, mm_AnIsoTropic);
SetWindowExtEx(FCanvas.Handle, Image.Width, Image.Height, pPSize); {$IFDEF WIN32}
{$ELSE} SetWindowOrgEx(FCanvas.Handle, 0, 0, pPPoint);
SetWindowOrg(FCanvas.Handle, 0, 0); SetWindowExtEx(FCanvas.Handle, Image.Width, Image.Height, pPSize);
SetWindowExt(FCanvas.Handle, Image.Width, Image.Height); {$ELSE}
{$ENDIF} SetWindowOrg(FCanvas.Handle, 0, 0);
FCanvas.StretchDraw(rect(0,0, Image.Width, Image.Height), Image.Picture.Graphic); SetWindowExt(FCanvas.Handle, Image.Width, Image.Height);
hmf:=CloseMetafile(FCanvas.Handle); {$ENDIF}
{$IFDEF WIN32} FCanvas.StretchDraw(rect(0, 0, Image.Width, Image.Height), Image.Picture.Graphic);
dwSize:=GetMetaFileBitsEx(hmf,dwSize,nil); hmf := CloseMetafile(FCanvas.Handle);
GetMem(lpBits,dwSize); {$IFDEF WIN32}
GetMetaFileBitsEx(hmf,dwSize,lpBits); dwSize := GetMetaFileBitsEx(hmf, dwSize, nil);
{$ELSE} GetMem(lpBits, dwSize);
hGlobal := GetMetaFileBits( hmf ); GetMetaFileBitsEx(hmf, dwSize, lpBits);
dwSize := GlobalSize(hGlobal); {$ELSE}
lpBits := GlobalLock( hGlobal ); hGlobal := GetMetaFileBits( hmf );
{$ENDIF} dwSize := GlobalSize(hGlobal);
h:= Image.Height; lpBits := GlobalLock( hGlobal );
h1:=h; {$ENDIF}
w:= Image.Width; h := Image.Height;
w1:=w; h1 := h;
h:= (h/Screen.pixelsperinch)*1440.0; w := Image.Width;
w:= (w/Screen.pixelsperinch)*1440.0; w1 := w;
h1:=26.46875*h1; h := (h / Screen.pixelsperinch) * 1440.0;
w1:=26.46875*w1; w := (w / Screen.pixelsperinch) * 1440.0;
Align:=GetRTFAlignment(Alignment); h1 := 26.46875 * h1;
StreamWriteStr(RTF,'\par \pard'+Align+'\plain\cgrid {\pict'); w1 := 26.46875 * w1;
StreamWriteStr(RTF,'\picscalex100'); Align := GetRTFAlignment(Alignment);
StreamWriteStr(RTF,'\picscaley100'); StreamWriteStr(RTF, '\par \pard' + Align + '\plain\cgrid {\pict');
StreamWriteStr(RTF,'\piccropl0'); StreamWriteStr(RTF, '\picscalex100');
StreamWriteStr(RTF,'\piccropr0'); StreamWriteStr(RTF, '\picscaley100');
StreamWriteStr(RTF,'\piccropt0'); StreamWriteStr(RTF, '\piccropl0');
StreamWriteStr(RTF,'\piccropb0'); StreamWriteStr(RTF, '\piccropr0');
StreamWriteStr(RTF,'\picw'+ inttostr(round(w1))); StreamWriteStr(RTF, '\piccropt0');
StreamWriteStr(RTF,'\pich'+ inttostr(round(h1))); StreamWriteStr(RTF, '\piccropb0');
StreamWriteStr(RTF,'\picwgoal'+inttostr(round(w))); StreamWriteStr(RTF, '\picw' + inttostr(round(w1)));
StreamWriteStr(RTF,'\pichgoal'+inttostr(round(h))); StreamWriteStr(RTF, '\pich' + inttostr(round(h1)));
StreamWriteStr(RTF,'\wmetafile8 \bin'+IntToStr(dwSize)); StreamWriteStr(RTF, '\picwgoal' + inttostr(round(w)));
RTF.Write(lpBits^,dwSize); StreamWriteStr(RTF, '\pichgoal' + inttostr(round(h)));
{$IFDEF WIN32} StreamWriteStr(RTF, '\wmetafile8 \bin' + IntToStr(dwSize));
FreeMem(lpBits); RTF.Write(lpBits^, dwSize);
{$ELSE} {$IFDEF WIN32}
GlobalUnLock( hGlobal ); FreeMem(lpBits);
{$ENDIF} {$ELSE}
StreamWriteStr(RTF,'}'); GlobalUnLock( hGlobal );
DeleteMetaFile(hmf); {$ENDIF}
FCanvas.Free; StreamWriteStr(RTF, '}');
DeleteMetaFile(hmf);
FCanvas.Free;
end; end;
procedure TCtrlToRTF.MemoToRTF(Memo:TMemo); procedure TCtrlToRTF.MemoToRTF(Memo: TMemo);
var i:Integer; var i: Integer;
Align, FontColor,FontAttrib,FontSize,FontName:String; Align, FontColor, FontAttrib, FontSize, FontName: String;
begin begin
Align:=GetRTFAlignment(Memo.Alignment); Align := GetRTFAlignment(Memo.Alignment);
FontColor:=GetRTFFontColorTableName(Memo.Font.Color); FontColor := GetRTFFontColorTableName(Memo.Font.Color);
FontSize:=GetRTFFontSize(Memo.Font.Size); FontSize := GetRTFFontSize(Memo.Font.Size);
FontAttrib:=GetRTFFontAttrib(Memo.Font.Style); FontAttrib := GetRTFFontAttrib(Memo.Font.Style);
FontName:=GetRTFFontTableName(Memo.Font.Name); FontName := GetRTFFontTableName(Memo.Font.Name);
StreamWriteStr(RTF,'\par \pard'+Align+'\plain'+FontName+FontSize+FontAttrib+FontColor); StreamWriteStr(RTF, '\par \pard' + Align + '\plain' + FontName + FontSize + FontAttrib + FontColor);
for i:=0 to Memo.Lines.Count-1 do for i := 0 to Memo.Lines.Count - 1 do
begin begin
StreamWriteStr(RTF,' \par '+Memo.Lines[i]); StreamWriteStr(RTF, ' \par ' + Memo.Lines[i]);
end; end;
end; end;
procedure TCtrlToRTF.LabelToRTF(pLabel:TLabel); procedure TCtrlToRTF.LabelToRTF(pLabel: TLabel);
var i:Integer; var
Align, FontColor,FontAttrib,FontSize,FontName:String; Align, FontColor, FontAttrib, FontSize, FontName: String;
begin begin
Align:=GetRTFAlignment(pLabel.Alignment); Align := GetRTFAlignment(pLabel.Alignment);
FontColor:=GetRTFFontColorTableName(pLabel.Font.Color); FontColor := GetRTFFontColorTableName(pLabel.Font.Color);
FontSize:=GetRTFFontSize(pLabel.Font.Size); FontSize := GetRTFFontSize(pLabel.Font.Size);
FontAttrib:=GetRTFFontAttrib(pLabel.Font.Style); FontAttrib := GetRTFFontAttrib(pLabel.Font.Style);
FontName:=GetRTFFontTableName(pLabel.Font.Name); FontName := GetRTFFontTableName(pLabel.Font.Name);
StreamWriteStr(RTF,'\par \pard'+Align+'\plain'+FontName+FontSize+FontAttrib+FontColor+' '+pLabel.Caption); StreamWriteStr(RTF, '\par \pard' + Align + '\plain' + FontName + FontSize + FontAttrib + FontColor + ' ' + pLabel.Caption);
end; end;
procedure TCtrlToRTF.TextBufToRTF(TextBuf:pointer;size:word;Font:TFont;Alignment:TAlignment); procedure TCtrlToRTF.TextBufToRTF(TextBuf: pointer; size: word; Font: TFont; Alignment: TAlignment);
var i:Integer; var
Align, FontColor,FontAttrib,FontSize,FontName:String; Align, FontColor, FontAttrib, FontSize, FontName: String;
begin begin
Align:=GetRTFAlignment(Alignment); Align := GetRTFAlignment(Alignment);
FontColor:=GetRTFFontColorTableName(Font.Color); FontColor := GetRTFFontColorTableName(Font.Color);
FontSize:=GetRTFFontSize(Font.Size); FontSize := GetRTFFontSize(Font.Size);
FontAttrib:=GetRTFFontAttrib(Font.Style); FontAttrib := GetRTFFontAttrib(Font.Style);
FontName:=GetRTFFontTableName(Font.Name); FontName := GetRTFFontTableName(Font.Name);
StreamWriteStr(RTF,'\par \pard'+Align+'\plain'+FontName+FontSize+FontAttrib+FontColor+' \par'); StreamWriteStr(RTF, '\par \pard' + Align + '\plain' + FontName + FontSize + FontAttrib + FontColor + ' \par');
RTF.Write(TextBuf^,size); RTF.Write(TextBuf^, size);
end; end;
procedure TCtrlToRTF.ListBoxToRTF(pList:TListBox); procedure TCtrlToRTF.ListBoxToRTF(pList: TListBox);
var i:Integer; var i: Integer;
FontColor,FontAttrib,FontSize,FontName:String; FontColor, FontAttrib, FontSize, FontName: String;
begin begin
FontColor:=GetRTFFontColorTableName(pList.Font.Color); FontColor := GetRTFFontColorTableName(pList.Font.Color);
FontSize:=GetRTFFontSize(pList.Font.Size); FontSize := GetRTFFontSize(pList.Font.Size);
FontAttrib:=GetRTFFontAttrib(pList.Font.Style); FontAttrib := GetRTFFontAttrib(pList.Font.Style);
FontName:=GetRTFFontTableName(pList.Font.Name); FontName := GetRTFFontTableName(pList.Font.Name);
StreamWriteStr(RTF,'\par \pard\plain'+FontName+FontSize+FontAttrib+FontColor); StreamWriteStr(RTF, '\par \pard\plain' + FontName + FontSize + FontAttrib + FontColor);
for i:=0 to pList.Items.Count-1 do for i := 0 to pList.Items.Count - 1 do
begin begin
StreamWriteStr(RTF,' \par '+pList.Items[i]); StreamWriteStr(RTF, ' \par ' + pList.Items[i]);
end; end;
end; end;
procedure TCtrlToRTF.StringListToRTF(pStringList:TStringList;Font:TFont;Alignment:TAlignment); procedure TCtrlToRTF.StringListToRTF(pStringList: TStringList; Font: TFont; Alignment: TAlignment);
var i:Integer; var i: Integer;
Align, FontColor,FontAttrib,FontSize,FontName:String; Align, FontColor, FontAttrib, FontSize, FontName: String;
begin begin
Align:=GetRTFAlignment(Alignment); Align := GetRTFAlignment(Alignment);
FontColor:=GetRTFFontColorTableName(Font.Color); FontColor := GetRTFFontColorTableName(Font.Color);
FontSize:=GetRTFFontSize(Font.Size); FontSize := GetRTFFontSize(Font.Size);
FontAttrib:=GetRTFFontAttrib(Font.Style); FontAttrib := GetRTFFontAttrib(Font.Style);
FontName:=GetRTFFontTableName(Font.Name); FontName := GetRTFFontTableName(Font.Name);
StreamWriteStr(RTF,'\par \pard'+Align+'\plain'+FontName+FontSize+FontAttrib+FontColor); StreamWriteStr(RTF, '\par \pard' + Align + '\plain' + FontName + FontSize + FontAttrib + FontColor);
for i:=0 to pStringList.Count-1 do for i := 0 to pStringList.Count - 1 do
begin begin
StreamWriteStr(RTF,' \par '+pStringList.strings[i]); StreamWriteStr(RTF, ' \par ' + pStringList.strings[i]);
end; end;
end; end;
procedure TCtrlToRTF.StringToRTF(pString:String;Font:TFont;Alignment:TAlignment); procedure TCtrlToRTF.StringToRTF(pString: String; Font: TFont; Alignment: TAlignment);
var Align, FontColor,FontAttrib,FontSize,FontName:String; var Align, FontColor, FontAttrib, FontSize, FontName: String;
begin begin
Align:=GetRTFAlignment(Alignment); Align := GetRTFAlignment(Alignment);
FontColor:=GetRTFFontColorTableName(Font.Color); FontColor := GetRTFFontColorTableName(Font.Color);
FontSize:=GetRTFFontSize(Font.Size); FontSize := GetRTFFontSize(Font.Size);
FontAttrib:=GetRTFFontAttrib(Font.Style); FontAttrib := GetRTFFontAttrib(Font.Style);
FontName:=GetRTFFontTableName(Font.Name); FontName := GetRTFFontTableName(Font.Name);
StreamWriteStr(RTF,'\par \pard'+Align+'\plain'+FontName+FontSize+FontAttrib+FontColor+' '+pString); StreamWriteStr(RTF, '\par \pard' + Align + '\plain' + FontName + FontSize + FontAttrib + FontColor + ' ' + pString);
end; end;
procedure TCtrlToRTF.EditToRTF(pEdit:TEdit); procedure TCtrlToRTF.EditToRTF(pEdit: TEdit);
begin begin
StringToRTF(pEdit.Text,pEdit.Font,taLeftJustify); StringToRTF(pEdit.Text, pEdit.Font, taLeftJustify);
end; end;
function TCtrlToRTF.GetRTFFontTableName(FontName:string):string; function TCtrlToRTF.GetRTFFontTableName(FontName: string): string;
var i:Integer; var i: Integer;
begin begin
Result := '\f0'; Result := '\f0';
for i:=0 to FontTable.Count-1 do for i := 0 to FontTable.Count - 1 do
begin begin
if Pos(FontName,FontTable.Strings[i]) > 0 then if Pos(FontName, FontTable.Strings[i]) > 0 then
begin begin
Result := '\f'+IntToStr(i); Result := '\f' + IntToStr(i);
Exit; Exit;
end; end;
end; end;
end; end;
function TCtrlToRTF.GetRTFFontAttrib(Style:TFontStyles):string; function TCtrlToRTF.GetRTFFontAttrib(Style: TFontStyles): string;
var retval:string; var retval: string;
begin begin
retval:=''; retval := '';
if fsBold in Style then if fsBold in Style then
retval := retval+'\b'; retval := retval + '\b';
if fsItalic in Style then if fsItalic in Style then
retval := retval+'\c'; retval := retval + '\c';
if fsUnderline in Style then if fsUnderline in Style then
retval := retval+'\ul'; retval := retval + '\ul';
if fsStrikeOut in Style then if fsStrikeOut in Style then
retval := retval+'\strike'; retval := retval + '\strike';
Result:=retval; Result := retval;
end; end;
function TCtrlToRTF.GetRTFFontSize(Size:Integer):string; function TCtrlToRTF.GetRTFFontSize(Size: Integer): string;
begin begin
Result:='\fs'+IntToStr(size*2); Result := '\fs' + IntToStr(size * 2);
end; end;
function TCtrlToRTF.GetRTF: String; function TCtrlToRTF.GetRTF: String;
var var
A : TStringList; A: TStringList;
begin begin
StreamWriteStr(RTF,#13#10+'}}'); StreamWriteStr(RTF, #13#10 + '}}');
RTF.Position := 0; RTF.Position := 0;
A := TStringList.Create; A := TStringList.Create;
try try
A.LoadFromStream(RTF); A.LoadFromStream(RTF);
Result := A.Text; Result := A.Text;
finally finally
FreeANDNIL(A); FreeANDNIL(A);
end; end;
end; end;
function TCtrlToRTF.GetRTFAlignment(Alignment:TAlignment):string; function TCtrlToRTF.GetRTFAlignment(Alignment: TAlignment): string;
var Align:String; var Align: String;
begin begin
if Alignment = taCenter then Align := '\qc' if Alignment = taCenter then Align := '\qc'
else if Alignment = taRightJustify then Align := '\qr' else if Alignment = taRightJustify then Align := '\qr'
else Align:=''; else Align := '';
Result := Align; Result := Align;
end; end;
function TCtrlToRTF.GetRTFFontColorTableName(Color:TColor):string; function TCtrlToRTF.GetRTFFontColorTableName(Color: TColor): string;
begin begin
if Color = clBlack then Result:='\cf0' if Color = clBlack then Result := '\cf0'
else if Color =clMaroon then Result:='\cf1' else if Color = clMaroon then Result := '\cf1'
else if Color =clGreen then Result:='\cf2' else if Color = clGreen then Result := '\cf2'
else if Color =clOlive then Result:='\cf3' else if Color = clOlive then Result := '\cf3'
else if Color =clNavy then Result:='\cf4' else if Color = clNavy then Result := '\cf4'
else if Color =clPurple then Result:='\cf5' else if Color = clPurple then Result := '\cf5'
else if Color =clTeal then Result:='\cf6' else if Color = clTeal then Result := '\cf6'
else if Color =clGray then Result:='\cf7' else if Color = clGray then Result := '\cf7'
else if Color =clSilver then Result:='\cf8' else if Color = clSilver then Result := '\cf8'
else if Color =clRed then Result:='\cf9' else if Color = clRed then Result := '\cf9'
else if Color =clLime then Result:='\cf10' else if Color = clLime then Result := '\cf10'
else if Color =clYellow then Result:='\cf11' else if Color = clYellow then Result := '\cf11'
else if Color =clBlue then Result:='\cf12' else if Color = clBlue then Result := '\cf12'
else if Color =clFuchsia then Result:='\cf13' else if Color = clFuchsia then Result := '\cf13'
else if Color =clAqua then Result:='\cf14' else if Color = clAqua then Result := '\cf14'
else if Color =clWhite then Result:='\cf15'; else if Color = clWhite then Result := '\cf15';
end; end;
procedure TCtrlToRTF.AddFontToTable(Font:TFont); procedure TCtrlToRTF.AddFontToTable(Font: TFont);
var DC: HDC; var DC: HDC;
SaveFont: HFont; SaveFont: HFont;
SysMetrics, Metrics: TTextMetric; Metrics: TTextMetric;
Temp:byte; Temp: byte;
I: Integer; I: Integer;
charset,family:string; charset, family: string;
begin begin
DC := GetDC(0); DC := GetDC(0);
SaveFont := SelectObject(DC, Font.Handle); SaveFont := SelectObject(DC, Font.Handle);
GetTextMetrics(DC, Metrics); GetTextMetrics(DC, Metrics);
SelectObject(DC, SaveFont); SelectObject(DC, SaveFont);
ReleaseDC(0, DC); ReleaseDC(0, DC);
for I:=0 to FontTable.Count-1 do for I := 0 to FontTable.Count - 1 do
begin begin
if Pos(Font.Name,FontTable.Strings[i]) > 0 then if Pos(Font.Name, FontTable.Strings[i]) > 0 then
Exit; Exit;
end; end;
case Metrics.tmCharSet of case Metrics.tmCharSet of
ANSI_CHARSET: charset:='fcharset0'; ANSI_CHARSET: charset := 'fcharset0';
DEFAULT_CHARSET: charset:='fcharset1'; DEFAULT_CHARSET: charset := 'fcharset1';
SYMBOL_CHARSET: charset:='fcharset2'; SYMBOL_CHARSET: charset := 'fcharset2';
SHIFTJIS_CHARSET: charset:='fcharset128'; SHIFTJIS_CHARSET: charset := 'fcharset128';
OEM_CHARSET: charset:='fcharset255'; OEM_CHARSET: charset := 'fcharset255';
else charset:=''; else charset := '';
end; end;
Temp:=Metrics.tmPitchAndFamily; Temp := Metrics.tmPitchAndFamily;
Temp:= (Temp shr 4) shl 4; Temp := (Temp shr 4) shl 4;
case Temp of case Temp of
FF_DECORATIVE: family:='fdecorative'; FF_DECORATIVE: family := 'fdecorative';
FF_DONTCARE: family:='fdontcare'; FF_DONTCARE: family := 'fdontcare';
FF_MODERN: family:='fmodern'; FF_MODERN: family := 'fmodern';
FF_ROMAN: family:='froman'; FF_ROMAN: family := 'froman';
FF_SCRIPT: family:='fscript'; FF_SCRIPT: family := 'fscript';
FF_SWISS: family:='fswiss'; FF_SWISS: family := 'fswiss';
else family:='froman'; else family := 'froman';
end; end;
FontTable.Add('{\f'+IntToStr(FontTable.Count)+'\'+family+'\'+charset+' '+font.name+';}'); FontTable.Add('{\f' + IntToStr(FontTable.Count) + '\' + family + '\' + charset + ' ' + font.name + ';}');
end; end;
procedure TCtrlToRTF.SaveToFile(pFileName:String); procedure TCtrlToRTF.SaveToFile(pFileName: String);
begin begin
StreamWriteStr(RTF,#13#10+'}}'); StreamWriteStr(RTF, #13#10 + '}}');
RTF.SaveToFile(pFileName); RTF.SaveToFile(pFileName);
end; end;
procedure TCtrlToRTF.StreamWriteStr(var ms: TMemoryStream; s: string); procedure TCtrlToRTF.StreamWriteStr(var ms: TMemoryStream; s: string);
begin begin
ms.Write(s[1], Length(s)); ms.Write(s[1], Length(s));
end; end;
procedure Register; procedure Register;
begin begin
RegisterComponents('CynapSYS', [TCtrlToRTF]); RegisterComponents('CynapSYS', [TCtrlToRTF]);
end; end;
end. end.

86
Source/Base/Utiles/uDataTableUtils.pas
View File

@ -22,9 +22,6 @@ procedure DesconectarTabla (ATarget: TDADataTable);
procedure CopyDataTableDA5(ASource : TDADataTable; ATarget: TDADataTable; procedure CopyDataTableDA5(ASource : TDADataTable; ATarget: TDADataTable;
const OnlySelectedRows : Boolean = False); const OnlySelectedRows : Boolean = False);
procedure CopyDataTableDA3(ASource : TDADataTable; ATarget : TDADataTable;
const OnlySelectedRows : Boolean = False);
procedure CloneDataTable(const ASource : TDACDSDataTable; procedure CloneDataTable(const ASource : TDACDSDataTable;
var ATarget : TDACDSDataTable; var ATarget : TDACDSDataTable;
RemoteUpdate: Boolean = True); overload; RemoteUpdate: Boolean = True); overload;
@ -344,89 +341,6 @@ begin
end; end;
procedure CopyDataTableDA3(ASource : TDADataTable; ATarget : TDADataTable;
const OnlySelectedRows : Boolean = False);
var
DABin: Binary;
DAAdapter : TDABINAdapter;
AFilter : String;
AFiltered : Boolean;
AObj : ISeleccionable;
i : Integer;
begin
AFilter := '';
AFiltered := False;
if OnlySelectedRows then
begin
if not Supports(ASource, ISeleccionable, aObj) then
raise Exception.Create('El origen de datos no soporta la interfaz ISeleccionable (CopyDataTable)');
if ASource.Filtered then
begin
AFiltered := True;
AFilter := ASource.Filter;
ASource.Filtered := False;
end;
ASource.Filter := '';
if ASource.Active then
ASource.Close;
//Si no hay elemento seleccionados filtramos para que ATarget se quede vacia
if (AObj.SelectedRecords.Count = 0) then
ASource.Filter := ASource.Filter + '(ID = ' + IntToStr(ID_NULO) + ')'
//En caso contrario filtramos por los elementos seleccionados
else
for i := 0 to AObj.SelectedRecords.Count - 1 do
begin
if (i > 0) then
ASource.Filter := ASource.Filter + ' or ';
ASource.Filter := ASource.Filter + '(ID = ' + IntToStr(AObj.SelectedRecords.Items[i]) + ')';
end;
ASource.Filtered := True;
end;
DABin := Binary.Create;
DAAdapter := TDABINAdapter.Create(nil);
ShowHourglassCursor;
ASource.DisableControls;
ATarget.DisableControls;
try
ATarget.LogicalName := ASource.LogicalName; // We need to specify new dataset LogicalName
ATarget.RemoteFetchEnabled := False; // "Desconectamos" la tabla destino del servidor
if not ASource.Active then
ASource.Open;
ASource.First;
DAAdapter.WriteDataset(DABin, ASource, [woRows]);
DAAdapter.ReadDataset(DABin, ATarget);
DAAdapter.Finalize;
ATarget.RemoteFetchEnabled := True; // "Conectamos" la tabla del servidor otra vez
// Dejar el filtro de la tabla origen como estaba
if OnlySelectedRows then
begin
ASource.Filtered := False;
ASource.Filter := AFilter;
if AFiltered then
ASource.Filtered := True;
end;
finally
FreeAndNil(DABin);
FreeAndNil(DAAdapter);
ASource.EnableControls;
ATarget.EnableControls;
HideHourglassCursor;
end;
end;
procedure DuplicarRegistro(ASource : TDADataTable; ATarget : TDADataTable; Const WithPKKey: Boolean = False; Const WithFKKey: Boolean = False); procedure DuplicarRegistro(ASource : TDADataTable; ATarget : TDADataTable; Const WithPKKey: Boolean = False; Const WithFKKey: Boolean = False);
var var
i, j: Integer; i, j: Integer;

2
Source/Base/Utiles/uReferenciasUtils.pas
View File

@ -26,7 +26,7 @@ begin
if StrIsDigit(Aux1) and StrIsDigit(Aux2) then if StrIsDigit(Aux1) and StrIsDigit(Aux2) then
Result := VarCompare(StrToIntSafe(Aux1), StrToIntSafe(Aux2)) Result := VarCompare(StrToIntSafe(Aux1), StrToIntSafe(Aux2))
else else
VarCompare(Aux1, Aux2) Result := VarCompare(Aux1, Aux2)
end; end;
end. end.