summaryrefslogtreecommitdiff
path: root/extras
diff options
context:
space:
mode:
Diffstat (limited to 'extras')
-rw-r--r--extras/tiopf/gui/tiRtfReport.pas4632
-rw-r--r--extras/tiopf/mvp/basic_intf.pas42
-rw-r--r--extras/tiopf/mvp/fpgui_intf.pas2
-rw-r--r--extras/tiopf/tiOPFfpGUI.lpk6
-rw-r--r--extras/tiopf/tiOPFfpGUI.pas2
5 files changed, 4660 insertions, 24 deletions
diff --git a/extras/tiopf/gui/tiRtfReport.pas b/extras/tiopf/gui/tiRtfReport.pas
new file mode 100644
index 00000000..5d8d9c53
--- /dev/null
+++ b/extras/tiopf/gui/tiRtfReport.pas
@@ -0,0 +1,4632 @@
+{
+
+Revision history:
+
+ 05-07-2005: First release by Marius Ellen (mariusellen@home.nl)
+ 2007-04-18: Ported to Free Pascal and fpGUI by Graeme Geldenhuys (graemeg@gmail.com)
+
+Purpose:
+ Create reports with Rtf documents with access to dataset and framework objects.
+
+ToDo:
+ Better exception handling. (saw some unexpected errors while parsing)
+ corrupting the resulting rtf.
+ Show errors when trying to past eof in a tiPerObjList (its now ignored)
+ Suppress null dates (0 date are displayed as xx-xx-1899)
+
+ And if anybody got ideas for this section, please email them!
+}
+
+unit tiRtfReport;
+
+{$mode objfpc}{$H+}
+{.$I tiDefines.inc}
+
+interface
+
+uses
+ Classes, SysUtils, contnrs, TypInfo{, Jpeg},
+ Db, Variants, tiObject, gfxbase;
+
+type
+ TtiRtfParser = class;
+ TRtfArgument = class;
+ TRtfException = class(Exception);
+
+ TRtfClass =(RtfNothing, RtfUnknown, RtfGroup, RtfText, RtfControl,
+ RtfExpression, RtfBranche, RtfParseBegin, RtfParseEnd, RtfEOF);
+
+ TRtfToken =(etNothing, etComma, etFunction, etProcedure, etParenthesis,
+ etADD, etSUB, etMUL, etDIV, etEQ, etNE, etGE, etLE, etGT, etLT, etNot,
+ etAnd, etOr, etAssign, etFieldName, etVariable, etDataset, etLitString,
+ etLitInt, etLitFloat, etLitDate, etLitFalse, etLitTrue);
+ TRtfTokenSet = set of TRtfToken;
+
+ TRtfPictureOption =(poMetafile, poBinary);
+ TRtfPictureOptions = set of TRtfPictureOption;
+ TRtfPictureBorder =(brNone, brSingle, brDouble, brThick, brShadow, brDot, brHair);
+
+ TColor = TfpgColor;
+ TPicture = TMemoryStream; // fake it until we can implement image support
+
+
+ TRtfPictureAttr = class(TObject)
+ private
+ FWidth: integer;
+ FHeigth: integer;
+ FScaleX: integer;
+ FScaleY: integer;
+ FWidthmm: Double;
+ FHeigthmm: Double;
+ FBorderWidth: integer;
+ FBorderColor: TColor;
+ FProportional: boolean;
+ FBorderType: TRtfPictureBorder;
+ procedure SetScaleX(Value: integer);
+ procedure SetScaleY(Value: integer);
+ public
+ constructor Create(AWidth, AHeigth: word);
+ //Width and height are in pixels
+ property Width: integer read FWidth;
+ property Heigth: integer read FHeigth;
+ //Widthmm and heightmm are in milimeters
+ property Widthmm: Double read FWidthmm;
+ property Heigthmm: Double read FHeigthmm;
+ //Scale from 1 to 100
+ property ScaleX: integer read FScaleX write SetScaleX;
+ property ScaleY: integer read FScaleY write SetScaleY;
+ property BorderColor: TColor read FBorderColor write FBorderColor;
+ property BorderWidth: integer read FBorderWidth write FBorderWidth; //in points
+ property BorderType: TRtfPictureBorder read FBorderType write FBorderType;
+ property Proportional: boolean read FProportional write FProportional;
+ end;
+
+
+ TRtfPicturePath = procedure(var AFilename: string)of object;
+ TRtfFunctionExecute = procedure(AArgument: TRtfArgument)of object;
+ TRtfOnPictureAttr = procedure(APictureAttr: TRtfPictureAttr)of object;
+ TRtfArgumentEvent = procedure(APrevItem, AArgument, ANextItem: TRtfArgument)of object;
+ TRtfOnCreateDataset = procedure(ADatabase, AAlias, ASql: string; AArgument: TRtfArgument)of object;
+
+
+ //Basic Rtf control word
+ TRtfItem = class(TList)
+ private
+ FNext: TRtfItem;
+ FPrev: TRtfItem;
+ FParent: TRtfItem;
+ FRtfMajor: integer;
+ FRtfMinor: integer;
+ FRtfClass: TRtfClass;
+ FRtfTextBuf: string;
+ function GetItem(Index: integer): TRtfItem;
+ function CheckItem(AClass: TRtfClass; Major: integer): boolean;
+ protected
+ procedure Notify(Ptr: pointer; Action: TListNotification); override;
+ public
+ procedure Assign(ASource: TRtfItem); virtual;
+ property Next: TRtfItem read FNext;
+ property Prev: TRtfItem read FPrev;
+ property Parent: TRtfItem read FParent;
+ //Weak names, but it keeps the RawRtfParser simple
+ property RtfClass: TRtfClass read FRtfClass write FRtfClass;
+ property RtfMajor: integer read FRtfMajor write FRtfMajor;
+ property RtfMinor: integer read FRtfMinor write FRtfMinor;
+ property RtfTextBuf: string read FRtfTextBuf write FRtfTextBuf;
+ property Items[Index: integer]: TRtfItem read GetItem; default;
+ end;
+
+
+ //Old style Double linked list (but still usefull)
+ TRtfItemList = class(TObject)
+ private
+ FHead: TRtfItem;
+ FTail: TRtfItem;
+ FCount: integer;
+ protected
+ procedure dlRemove(AItem: TRtfItem; DisposeIt: boolean);
+ public
+ constructor Create; virtual;
+ destructor Destroy; override;
+
+ procedure Clear;
+ function Add(AItem: TRtfItem): TRtfItem;
+ procedure SaveToStream(AStream: TStream; AColors: string);
+ procedure Insert(AItem: TRtfItem); {-Insert element at start of list}
+ procedure Delete(AItem: TRtfItem); {-Delete existing element in list, disposing of its contents}
+ procedure Extract(AItem: TRtfItem); {-Extract existing element from list without disposing of it}
+ procedure PlaceAfter(AItem, AAfter: TRtfItem); {-Place element P into list _after_ existing element L}
+ procedure PlaceBefore(AItem, ABefore: TRtfItem); {-Place element P into list _before_ existing element L}
+
+ property Head: TRtfItem read FHead; {-Return TRtfItem to head of list}
+ property Tail: TRtfItem read FTail; {-Return TRtfItem to tail of list}
+ property Count: integer read FCount;
+ end;
+
+
+ //Variable definition
+ TRtfVariable = class(TObject)
+ private
+ FName: string;
+ FValue: variant;
+ FToken: TRtfToken;
+ public
+ property Name: string read FName write FName;
+ property Value: variant read FValue write FValue;
+ property Token: TRtfToken read FToken write FToken;
+ end;
+
+
+ TRtfVariableList = class(TObjectList)
+ private
+ function GetItem(Index: integer): TRtfVariable;
+ public
+ destructor Destroy; override;
+ function Find(AName: string): TRtfVariable;
+ function Add(AName: string; AValue: variant; AToken: TRtfToken): TRtfVariable;
+ property Items[Index: integer]: TRtfVariable read GetItem; default;
+ end;
+
+
+ //Function definition
+ TRtfFunction = class(TObject)
+ private
+ FMin: smallint;
+ FMax: smallint;
+ FName: string;
+ FToken: TRtfToken;
+ FOnExecute: TRtfFunctionExecute;
+ public
+ property Name: string read FName write FName; //Function name
+ property Min: smallint read FMin write FMin; //Function minimal parameters
+ property Max: smallint read FMax write FMax; //Function maximal parameters
+ property Token: TRtfToken read FToken write FToken; //Function type (=weak name)
+ property OnExecute: TRtfFunctionExecute read FOnExecute write FOnExecute;
+ end;
+
+
+ TRtfFunctionList = class(TObjectList)
+ private
+ function GetItem(Index: integer): TRtfFunction;
+ public
+ function Find(AName: string): TRtfFunction;
+ function Add(ATokenType: TRtfToken; AName: string; AMin, AMax: smallint; AOnexecute: TRtfFunctionExecute): TRtfFunction;
+ property Items[Index: integer]: TRtfFunction read GetItem; default;
+ end;
+
+
+ //Dataset defintion (Simply a wrap around the TDataset compatible and framework objects)
+ TRtfDataset = class(TObjectList)
+ private
+ FName: string;
+ FDataset: TObject;
+ FParent: TRtfDataset;
+ FTableIndex: integer;
+ FFreeDataset: boolean;
+ function GetItem(Index: integer): TRtfDataset;
+ function ResolveNestedFields(ATable: TRtfDataset; AName: string; var AFieldName: string): TRtfDataset;
+ protected
+ procedure Notify(Ptr: pointer; Action: TListNotification); override;
+ public
+ destructor Destroy; override;
+ function Find(AName: string): TRtfDataset; overload;
+ function Find(AName: string; var AFieldName: string): TRtfDataset; overload;
+ function Add(ADataset: TObject; AName: string; AFreeDataset: boolean = false): TRtfDataset;
+ property Items[Index: integer]: TRtfDataset read GetItem; default;
+
+ procedure Open;
+ procedure Next;
+ procedure Prior;
+ procedure First;
+ procedure Last;
+ function Eof: boolean;
+ function Bof: boolean;
+ function IsEmpty: boolean;
+ function RecordCount: integer;
+
+ property Parent: TRtfDataset read FParent;
+ property Name: string read FName write FName; //TableName
+ property FreeDataset: boolean read FFreeDataset;
+ property Dataset: TObject read FDataset write FDataset;
+ property TableIndex: integer read FTableIndex write FTableIndex; //Record index
+ end;
+
+
+ //Argument definition (For evaluating of expressions)
+ TRtfArgument = class(TObjectList)
+ private
+ FValue: variant;
+ FParent: TRtfArgument;
+ FToken: TRtfToken;
+ FParam: integer;
+ FParser: TtiRtfParser;
+ procedure ResolveVariable;
+ procedure EvaluateExpression;
+ function GetItem(Index: integer): TRtfArgument;
+ function Add(AArgument: TRtfArgument): TRtfArgument; overload;
+ function Add(AValue: variant; ATokenType: TRtfToken): TRtfArgument; overload;
+ procedure Walk(ATokenset: TRtfTokenSet; AExecproc: TRtfArgumentEvent);
+ procedure EvaluateAssign(APrevItem, AArgument, ANextItem: TRtfArgument);
+ procedure EvaluateComparison(APrevItem, AArgument, ANextItem: TRtfArgument);
+ procedure EvaluateUnaryBinary(APrevItem, AArgument, ANextItem: TRtfArgument);
+ protected
+ procedure Notify(Ptr: pointer; Action: TListNotification); override;
+ //Dataset stuff
+ procedure ResolveFieldName;
+ function GetPicture(APicture: TPicture): string;
+ procedure GetGraphicsValue(ADataset: TRtfDataset; AFieldName: string);
+ procedure ResolveFieldValue(ADataset: TRtfDataset; AFieldName: string);
+ procedure GetPictureData(ABuffer: pointer; ALength: cardinal; var Result: string);
+ public
+ constructor Create(AParser: TtiRtfParser); overload;
+ procedure Evaluate;
+ function Check(AParam: integer; ATokens: TRtfTokenSet): boolean; overload;
+ function Check(ATokens: array of TRtfTokenSet): boolean; overload;
+ procedure ParseExpression(AExpression: string); virtual;
+
+ property Parser: TtiRtfParser read FParser;
+ property Parent: TRtfArgument read FParent; //Parent argument list
+ property Value: variant read FValue write FValue; //Argument value
+ property Param: integer read FParam write FParam; //Just for Scan(Dataset)
+ property Token: TRtfToken read FToken write FToken; //Argument type
+ property Items[Index: integer]: TRtfArgument read GetItem; default;
+ end;
+
+
+ //Color definition
+ TRtfColor = class(TObject)
+ private
+ FBlue: integer;
+ FRed: integer;
+ FGreen: integer;
+ function GetAsString: string;
+ public
+ property Red: integer read FRed write FRed;
+ property Green: integer read FGreen write FGreen;
+ property Blue: integer read FBlue write FBlue;
+ property AsString: string read GetAsString;
+ end;
+
+
+ TRtfColorList = class(TObjectlist)
+ private
+ function GetItem(Index: integer): TRtfColor;
+ function GetAsString: string;
+ public
+ property AsString: string read GetAsString;
+ procedure Clear; override;
+ function UseColor(AColor: TColor): integer; overload;
+ function Add(ARed, AGreen, ABlue: integer): integer;
+ function Find(ARed, AGreen, ABlue: integer): integer;
+ function UseColor(ARed, AGreen, ABlue: integer): integer; overload;
+ property Items[Index: integer]: TRtfColor read GetItem; default;
+ end;
+
+
+ //Parser definition
+ TtiRtfParser = class(TObject)
+ private
+ FBoolTrue: string;
+ FBoolFalse: string;
+ FHlpItems: TRtfItem;
+ TmpItems: TObjectlist;
+ FDatasets: TRtfDataset;
+ FRtfItems: TRtfItemList;
+ FErrorBackColor: TColor;
+ FErrorForeColor: TColor;
+ FRawItems: TRtfItemList;
+ FColorList: TRtfColorList;
+ FFunctions: TRtfFunctionList;
+ FVariables: TRtfVariableList;
+ FOnPicturePath: TRtfPicturePath;
+ FOnPictureAttr: TRtfOnPictureAttr;
+ FOnEvalutate: TRtfFunctionExecute;
+ FPictureOptions: TRtfPictureOptions;
+ FOnCreateDataset: TRtfOnCreateDataset;
+ procedure PreParse;
+ procedure Parse(AItems: TRtfItem);
+ procedure ParseExpression(AItem: TRtfItem);
+ function AddToRtfItems(AItem: TRtfItem): TRtfItem;
+ function SkipParagraph(AItem: TRtfItem): TRtfItem;
+ procedure UdfDateTimeTo(AArgument: TRtfArgument; AFormat: string);
+ protected
+ procedure AddFunctions; virtual;
+ procedure UdfDummy(AArgument: TRtfArgument);
+
+ //routines for date time
+ procedure UdfNow(AArgument: TRtfArgument);
+ procedure UdfDate(AArgument: TRtfArgument);
+ procedure UdfTime(AArgument: TRtfArgument);
+ procedure UdfYear(AArgument: TRtfArgument);
+ procedure UdfMonth(AArgument: TRtfArgument);
+ procedure UdfDay(AArgument: TRtfArgument);
+ procedure UdfShortDayName(AArgument: TRtfArgument);
+ procedure UdfShortMonthName(AArgument: TRtfArgument);
+ procedure UdfLongDayName(AArgument: TRtfArgument);
+ procedure UdfLongMonthName(AArgument: TRtfArgument);
+ procedure UdfSYear(AArgument: TRtfArgument);
+ procedure UdfSMonth(AArgument: TRtfArgument);
+ procedure UdfSDay(AArgument: TRtfArgument);
+ procedure UdfStod(AArgument: TRtfArgument);
+ procedure UdfDtos(AArgument: TRtfArgument);
+ procedure UdfDateToStr(AArgument: TRtfArgument);
+ procedure UdfTimeToStr(AArgument: TRtfArgument);
+ procedure UdfDateTimeToStr(AArgument: TRtfArgument);
+ procedure UdfStrToDate(AArgument: TRtfArgument);
+ procedure UdfStrToTime(AArgument: TRtfArgument);
+ procedure UdfStrToDateTime(AArgument: TRtfArgument);
+
+ //routines for strings, int, float etc.
+ procedure UdfInt(AArgument: TRtfArgument);
+ procedure UdfStr(AArgument: TRtfArgument);
+ procedure UdfVal(AArgument: TRtfArgument);
+ procedure UdfChr(AArgument: TRtfArgument);
+ procedure UdfNul(AArgument: TRtfArgument);
+ procedure UdfFrac(AArgument: TRtfArgument);
+ procedure UdfEmpty(AArgument: TRtfArgument);
+ procedure UdfPadr(AArgument: TRtfArgument);
+ procedure UdfPadl(AArgument: TRtfArgument);
+ procedure UdfLower(AArgument: TRtfArgument);
+ procedure UdfUpper(AArgument: TRtfArgument);
+ procedure UdfTrunc(AArgument: TRtfArgument);
+ procedure UdfRound(AArgument: TRtfArgument);
+ procedure UdfTrim(AArgument: TRtfArgument);
+ procedure UdfPower(AArgument: TRtfArgument);
+ procedure UdfIntPower(AArgument: TRtfArgument);
+ procedure UdfTrimLeft(AArgument: TRtfArgument);
+ procedure UdfTrimRight(AArgument: TRtfArgument);
+ procedure UdfSubStr(AArgument: TRtfArgument);
+ procedure UdfIntToStr(AArgument: TRtfArgument);
+ procedure UdfStrToInt(AArgument: TRtfArgument);
+ procedure UdfFloatToStr(AArgument: TRtfArgument);
+ procedure UdfStrToFloat(AArgument: TRtfArgument);
+ procedure UdfFormatFloat(AArgument: TRtfArgument);
+ procedure UdfFBool(AArgument: TRtfArgument);
+
+ //routines for conditinals
+ procedure UdfIf(AArgument: TRtfArgument);
+ procedure UdfIif(AArgument: TRtfArgument);
+
+ //routines for datasets
+ procedure UdfDataset(AArgument: TRtfArgument);
+ procedure UdfScan(AArgument: TRtfArgument);
+ procedure UdfBof(AArgument: TRtfArgument);
+ procedure UdfEof(AArgument: TRtfArgument);
+ procedure UdfNext(AArgument: TRtfArgument);
+ procedure UdfPrior(AArgument: TRtfArgument);
+ procedure UdfFirst(AArgument: TRtfArgument);
+ procedure UdfLast(AArgument: TRtfArgument);
+ procedure UdfOpen(AArgument: TRtfArgument);
+ procedure UdfIsEmpty(AArgument: TRtfArgument);
+ procedure UdfRecordCount(AArgument: TRtfArgument);
+
+ //misch routines
+ procedure UdfPicture(AArgument: TRtfArgument);
+ procedure UdfDbPicture(AArgument: TRtfArgument);
+ public
+ constructor Create; virtual;
+ destructor Destroy; override;
+
+ procedure Clear;
+ procedure Execute; virtual;
+
+ procedure LoadFromFile(AFilename: string);
+ procedure LoadFromString(AString: string);
+ procedure LoadFromStream(AStream: TMemoryStream);
+ procedure LoadFromBuffer(ABuffer: pchar; ASize: integer);
+
+ function SaveToString: string;
+ procedure SaveToFile(AFileName: string);
+ procedure SaveToStream(AStream: TMemoryStream);
+
+ function AddVariable(AName: string; AValue: variant; AToken: TRtfToken): TRtfVariable;
+ function AddDataset(ATable: TObject; AName: string; AFreeDataset: boolean = false): TRtfDataset;
+ function AddFunction(AName: string; ATokenType: TRtfToken; AMin, AMax: smallint; AOnexecute: TRtfFunctionExecute): TRtfFunction;
+
+
+ //these should all be hidden in component style
+ property RawItems: TRtfItemList read FRawItems;
+ property HlpItems: TRtfItem read FHlpItems;
+ property RtfItems: TRtfItemList read FRtfItems;
+ property Datasets: TRtfDataset read FDatasets;
+ property Functions: TRtfFunctionList read FFunctions;
+ property Variables: TRtfVariableList read FVariables;
+ property ColorList: TRtfColorList read FColorList;
+ property OnEvalutate: TRtfFunctionExecute read FOnEvalutate write FOnEvalutate; //For debug only
+ published
+ property BoolTrue: string read FBoolTrue write FBoolTrue;
+ property BoolFalse: string read FBoolFalse write FBoolFalse;
+ property ErrorForeColor: TColor read FErrorForeColor write FErrorForeColor default clRed;
+ property ErrorBackColor: TColor read FErrorBackColor write FErrorBackColor default clYellow;
+ property PictureOptions: TRtfPictureOptions read FPictureOptions write FPictureOptions default[poMetafile, poBinary];
+
+ property OnPicturePath: TRtfPicturePath read FOnPicturePath write FOnPicturePath;
+ property OnPictureAttr: TRtfOnPictureAttr read FOnPictureAttr write FOnPictureAttr;
+ property OnCreateDataset: TRtfOnCreateDataset read FOnCreateDataset write FOnCreateDataset;
+ end;
+
+implementation
+
+uses
+ math // IntPower() function
+ ,fpgfx // fpgApplication.HandleExeception()
+ ;
+
+resourcestring
+ rsNotImplemented = 'Not implemented';
+ rsInvalidDateConstant = 'Invalid date constant';
+ rsInvalidTimeConstant = 'Invalid time constant';
+ rsInvalidDateSeparator = 'Invalid date separator';
+ rsInvalidTimeSeparator = 'Invalid time separator';
+ rsInvalidDateTimeConstant = 'Invalid date/time constant';
+ rsInvalidExpressionCharacter = 'Invalid expression character "%s"';
+ rsUnterminatedStringConstant = 'Unterminated string constant';
+ rsToManyClosingParenthesis = 'Unexpected parenthesis';
+ rsExpectedClosingParenthesis = 'Missing closing parenthesis';
+ rsUnexpectedParameterType = 'Unexpected parameter type';
+
+type
+ TRtfKey = record
+ RtfKMajor: integer;
+ RtfKMinor: integer;
+ RtfKStr: string;
+ end;
+
+
+ TRawRtfParser = class(TObject)
+ private
+ APtr, AEnd: pchar;
+ APushedChar: char;
+ FRtfMajor: integer;
+ FRtfMinor: integer;
+ FRtfTextBuf: string;
+ AParseItem: TRtfItem;
+ FRtfClass: TRtfClass;
+ FColorTable: TRtfItem;
+ RawItems: TRtfItemList;
+ procedure RtfHook;
+ procedure GetRtfToken;
+ function GetRtfChar: char;
+ protected
+ property RtfClass: TRtfClass read FRtfClass;
+ property RtfMajor: integer read FRtfMajor;
+ property RtfMinor: integer read FRtfMinor;
+ property RtfTextBuf: string read FRtfTextBuf;
+ public
+ procedure Execute(ARawItems: TRtfItemList; ARtfPtr: pchar; ARtfSize: integer);
+
+ property ColorTable: TRtfItem read FColorTable;
+ end;
+
+
+
+const
+ {@indent off}
+ //Control class major numbers
+ //RtfVersion = 01;
+ //RtfDefFont = 02;
+ //RtfCharSet = 03;
+ RtfDestination = 04;
+ //RtfFontFamily = 05;
+ //RtfColorName = 06;
+ RtfSpecialChar = 07;
+ //RtfStyleAttr = 08;
+ //RtfDocAttr = 09;
+ //RtfSectAttr = 10;
+ //RtfTblAttr = 11;
+ RtfParAttr = 12;
+ //RtfCharAttr = 13;
+ //RtfPictAttr = 14;
+ //RtfNeXTGrAttr = 15;
+ //RtfFieldAttr = 16;
+ //RtfTOCAttr = 17;
+ //RtfPosAttr = 18;
+
+ //RtfExpression major numbers
+ RtfNormalExpression = 1;
+ RtfIfExpression = 2;
+ RtfThenExpression = 3;
+ RtfElseExpression = 4;
+ RtfEndifExpression = 5;
+ RtfScan = 6;
+ RtfScanEntry = 7;
+ RtfScanFooter = 8;
+ RtfScanEnd = 9;
+
+ //Group class major numbers
+ RtfBeginGroup = 01;
+ RtfEndGroup = 02;
+
+ //Control class minor numbers
+ {RtfAnsiCharSet = 0;
+ RtfMacCharSet = 1;
+ RtfPcCharSet = 2;
+ RtfPcaCharSet = 3;}
+
+
+ //Destination attributes minor numbers
+ {RtfPict = 0;
+ RtfNeXTGraphic = 1;
+ RtfFootnote = 2;
+ RtfHeader = 3;
+ RtfHeaderLeft = 4;
+ RtfHeaderRight = 5;
+ RtfHeaderFirst = 6;
+ RtfFooter = 7;
+ RtfFooterLeft = 8;
+ RtfFooterRight = 9;
+ RtfFooterFirst = 10;
+ RtfFNSep = 11;
+ RtfFNContSep = 12;
+ RtfFNContNotice = 13;}
+ RtfInfo = 14;
+ RtfStyleSheet = 15;
+ RtfFontTbl = 16;
+ RtfColorTbl = 17;
+ RtfField = 18;
+ {RtfFieldInst = 19;
+ RtfFieldResult = 20;
+ RtfIndex = 21;
+ RtfIndexBold = 22;
+ RtfIndexItalic = 23;
+ RtfIndexText = 24;
+ RtfIndexRange = 25;
+ RtfTOC = 26;
+ RtfBookmarkStart = 27;
+ RtfBookmarkEnd = 28;
+ RtfITitle = 29;
+ RtfISubject = 30;
+ RtfIAuthor = 31;
+ RtfIOperator = 32;
+ RtfIKeywords = 33;
+ RtfIComment = 34;
+ RtfIVersion = 35;
+ RtfIDoccomm = 36;}
+
+ //Fonts minor numbers
+ {RtfFFNil = 0;
+ RtfFFRoman = 1;
+ RtfFFSwiss = 2;
+ RtfFFModern = 3;
+ RtfFFScript = 4;
+ RtfFFDecor = 5;
+ RtfFFTech = 6;}
+
+ //Color attributes minor numbers
+ {RtfRed = 0;
+ RtfGreen = 1;
+ RtfBlue = 2;}
+
+ //Style attributes minor numbers
+ {RtfBasedOn = 0;
+ RtfNext = 1;}
+
+ //Special characters minor numbers
+ {RtfCurHeadPage = 0;
+ RtfCurFNote = 1;
+ RtfCurHeadPict = 2;
+ RtfCurHeadDate = 3;
+ RtfCurHeadTime = 4;}
+ RtfFormula = 5;
+ RtfNoBrkSpace = 6;
+ RtfNoReqHyphen = 7;
+ RtfNoBrkHyphen = 8;
+ {RtfPage = 9;
+ RtfLine = 10;}
+ RtfPar = 11;
+ {RtfSect = 12;}
+ RtfTab = 13;
+ {RtfCell = 14;
+ RtfRow = 15;
+ RtfCurAnnot = 16;
+ RtfAnnotation = 17;
+ RtfAnnotID = 18;
+ RtfCurAnnotRef = 19;
+ RtfFNoteSep = 20;
+ RtfFNoteCont = 21;
+ RtfColumn = 22;}
+ RtfOptDest = 23;
+ {RtfIIntVersion = 24;
+ RtfICreateTime = 25;
+ RtfIRevisionTime = 26;
+ RtfIPrintTime = 27;
+ RtfIBackupTime = 28;
+ RtfIEditTime = 29;
+ RtfIYear = 30;
+ RtfIMonth = 31;
+ RtfIDay = 32;
+ RtfIHour = 33;
+ RtfIMinute = 34;
+ RtfINPages = 35;
+ RtfINWords = 36;
+ RtfINChars = 37;
+ RtfIIntID = 38;}
+ RtflQuote = 39;
+ RtfrQuote = 40;
+ RtflDblQuote = 41;
+ RtfrDblQuote = 42;
+
+
+ //Document atributes minor numbers
+ {RtfPaperWidth = 0;
+ RtfPaperHeight = 1;
+ RtfLeftMargin = 2;
+ RtfRightMargin = 3;
+ RtfTopMargin = 4;
+ RtfBottomMargin = 5;
+ RtfFacingPage = 6;
+ RtfGutterWid = 7;
+ RtfDefTab = 8;
+ RtfWidowCtrl = 9;
+ RtfHyphHotZone = 10;
+ RtfFNoteEndSect = 11;
+ RtfFNoteEndDoc = 12;
+ RtfFNoteText = 13;
+ RtfFNoteBottom = 14;
+ RtfFNoteStart = 15;
+ RtfFNoteRestart = 16;
+ RtfPageStart = 17;
+ RtfLineStart = 18;
+ RtfLandscape = 19;
+ RtfFracWidth = 20;
+ RtfNextFile = 21;
+ RtfTemplate = 22;
+ RtfMakeBackup = 23;
+ RtfRtfDefault = 24;
+ RtfRevisions = 25;
+ RtfMirrorMargin = 26;
+ RtfRevDisplay = 27;
+ RtfRevBar = 28;}
+
+ //Sector attributes minor numbers
+ {RtfSectDef = 0;
+ RtfNoBreak = 1;
+ RtfColBreak = 2;
+ RtfPageBreak = 3;
+ RtfEvenBreak = 4;
+ RtfOddBreak = 5;
+ RtfPageStarts = 6;
+ RtfPageCont = 7;
+ RtfPageRestart = 8;
+ RtfPageDecimal = 9;
+ RtfPageURoman = 10;
+ RtfPageLRoman = 11;
+ RtfPageULetter = 12;
+ RtfPageLLetter = 13;
+ RtfPageNumLeft = 14;
+ RtfPageNumTop = 15;
+ RtfHeaderY = 16;
+ RtfFooterY = 17;
+ RtfLineModulus = 18;
+ RtfLineDist = 19;
+ RtfLineStarts = 20;
+ RtfLineRestart = 21;
+ RtfLineRestartPg = 22;
+ RtfLineCont = 23;
+ RtfTopVAlign = 24;
+ RtfBottomVAlign = 25;
+ RtfCenterVAlign = 26;
+ RtfJustVAlign = 27;
+ RtfColumns = 28;
+ RtfColumnSpace = 29;
+ RtfColumnLine = 30;
+ RtfENoteHere = 31;
+ RtfTitleSpecial = 32;}
+
+ //Table attributes minor numbers
+ {RtfCellBordBottom = 0;
+ RtfCellBordTop = 1;
+ RtfCellBordLeft = 2;
+ RtfCellBordRight = 3;
+ RtfRowDef = 4;
+ RtfRowLeft = 5;
+ RtfRowRight = 6;
+ RtfRowCenter = 7;
+ RtfRowGapH = 8;
+ RtfRowHt = 9;
+ RtfRowLeftEdge = 10;
+ RtfCellPos = 11;
+ RtfMergeRngFirst = 12;
+ RtfMergePrevious = 13;}
+
+ //Paragrapgh attributes minor numbers
+ RtfParDef = 0;
+ {RtfStyleNum = 1;
+ RtfQuadLeft = 2;
+ RtfQuadRight = 3;
+ RtfQuadJust = 4;
+ RtfQuadCenter = 5;
+ RtfFirstIndent = 6;
+ RtfLeftIndent = 7;
+ RtfRightIndent = 8;
+ RtfSpaceBefore = 9;
+ RtfSpaceAfter = 10;
+ RtfSpaceBetween = 11;
+ RtfInTable = 12;
+ RtfKeep = 13;
+ RtfKeepNext = 14;
+ RtfSideBySide = 15;
+ RtfPBBefore = 16;
+ RtfNoLineNum = 17;
+ RtfTabPos = 18;
+ RtfTabRight = 19;
+ RtfTabCenter = 20;
+ RtfTabDecimal = 21;
+ RtfTabBar = 22;
+ RtfBorderTop = 23;
+ RtfBorderBottom = 24;
+ RtfBorderLeft = 25;
+ RtfBorderRight = 26;
+ RtfBorderBox = 27;
+ RtfBorderBar = 28;
+ RtfBorderBetween = 29;
+ RtfBorderSingle = 30;
+ RtfBorderThick = 31;
+ RtfBorderShadow = 32;
+ RtfBorderDouble = 33;
+ RtfBorderDot = 34;
+ RtfBorderHair = 35;
+ RtfBorderSpace = 36;
+ RtfLeaderDot = 37;
+ RtfLeaderHyphen = 38;
+ RtfLeaderUnder = 39;
+ RtfLeaderThick = 40;}
+
+ //Character attributes minor numbers
+ {RtfPlain = 0;
+ RtfBold = 1;
+ RtfItalic = 2;
+ RtfStrikeThru = 3;
+ RtfOutline = 4;
+ RtfShadow = 5;
+ RtfSmallCaps = 6;
+ RtfAllCaps = 7;
+ RtfInvisible = 8;
+ RtfFontNum = 9;
+ RtfFontSize = 10;
+ RtfExpand = 11;
+ RtfUnderline = 12;
+ RtfWUnderline = 13;
+ RtfDUnderline = 14;
+ RtfDbUnderline = 15;
+ RtfNoUnderline = 16;
+ RtfSuperScript = 17;
+ RtfSubScript = 18;
+ RtfRevised = 19;
+ RtfForeColor = 20;
+ RtfBackColor = 21;
+ RtfGray = 22; }
+
+ //Picture attributes minor numbers
+ {RtfMacQD = 0;
+ RtfWinMetafile = 1;
+ RtfWinBitmap = 2;
+ RtfPicWid = 3;
+ RtfPicHt = 4;
+ RtfPicGoalWid = 5;
+ RtfPicGoalHt = 6;
+ RtfPicScaleX = 7;
+ RtfPicScaleY = 8;
+ RtfPicScaled = 9;
+ RtfPicCropTop = 10;
+ RtfPicCropBottom = 11;
+ RtfPicCropLeft = 12;
+ RtfPicCropRight = 13;
+ RtfPixelBits = 14;
+ RtfBitmapPlanes = 15;
+ RtfBitmapWid = 16;
+ RtfPicBinary = 17;}
+
+ //
+ {RtfNeXTGWidth = 0;
+ RtfNeXTGHeight = 1;}
+
+ //Field attributes minor numbers
+ {RtfFieldDirty = 0;
+ RtfFieldEdited = 1;
+ RtfFieldLocked = 2;
+ RtfFieldPrivate = 3;}
+
+ //Toc attributes minor numbers
+ {RtfTOCType = 0;
+ RtfTOCLevel = 1;}
+
+ //Position attributes minor numbers
+ {RtfPosX = 0;
+ RtfPosXCenter = 1;
+ RtfPosXInside = 2;
+ RtfPosXLeft = 3;
+ RtfPosXOutSide = 4;
+ RtfPosXRight = 5;
+ RtfPosY = 6;
+ RtfPosYInline = 7;
+ RtfPosYTop = 8;
+ RtfPosYCenter = 9;
+ RtfPosYBottom = 10;
+ RtfAbsWid = 11;
+ RtfTextDist = 12;
+ RtfRPosMargV = 13;
+ RtfRPosPageV = 14;
+ RtfRPosMargH = 15;
+ RtfRPosPageH = 16;
+ RtfRPosColH = 17;}
+
+const
+ //A reduced set of control words
+ RtfKey: array[0..15]of TRtfKey =
+ (
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfParDef; RtfKStr: '\pard' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfPar; RtfKStr: '\par' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfTab; RtfKStr: '\tab' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtflQuote; RtfKStr: '\lquote' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfrQuote; RtfKStr: '\rquote' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtflQuote; RtfKStr: '\'+Chr(39)+'91'),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfrQuote; RtfKStr: '\'+Chr(39)+'92'),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtflDblQuote; RtfKStr: '\ldblquote' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfrDblQuote; RtfKStr: '\rdblquote' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtflDblQuote; RtfKStr: '\'+Chr(39)+'93'),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfrDblQuote; RtfKStr: '\'+Chr(39)+'94'),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfInfo; RtfKStr: '\info' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfStyleSheet; RtfKStr: '\stylesheet' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfFontTbl; RtfKStr: '\fonttbl' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfColorTbl; RtfKStr: '\colortbl' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfField; RtfKStr: '\field' )
+ );
+
+ { You could also add the following (but i don't need all that):
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfCurHeadPict; RtfKStr: '\chpict' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfCurHeadDate; RtfKStr: '\chdate' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfCurHeadTime; RtfKStr: '\chtime' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfCurHeadPage; RtfKStr: '\chpgn' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfCurFNote; RtfKStr: '\chftn' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfCurAnnotRef; RtfKStr: '\chatn' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfFNoteSep; RtfKStr: '\chftnsep' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfFNoteCont; RtfKStr: '\chftnsepc' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfCell; RtfKStr: '\cell' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfRow; RtfKStr: '\row' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfSect; RtfKStr: '\sect' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfPage; RtfKStr: '\page' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfColumn; RtfKStr: '\column' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfLine; RtfKStr: '\line' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfIIntVersion; RtfKStr: '\vern' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfICreateTime; RtfKStr: '\creatim' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfIRevisionTime; RtfKStr: '\revtim' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfIPrintTime; RtfKStr: '\printim' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfIBackupTime; RtfKStr: '\buptim' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfIEditTime; RtfKStr: '\edmins' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfIYear; RtfKStr: '\yr' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfIMonth; RtfKStr: '\mo' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfIDay; RtfKStr: '\dy' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfIHour; RtfKStr: '\hr' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfIMinute; RtfKStr: '\min' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfINPages; RtfKStr: '\nofpages' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfINWords; RtfKStr: '\nofwords' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfINChars; RtfKStr: '\nofchars' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfIIntID; RtfKStr: '\id' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfPict; RtfKStr: '\pict' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfNeXTGraphic; RtfKStr: '\nextgraphic' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfFootnote; RtfKStr: '\footnote' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfHeader; RtfKStr: '\header' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfHeaderLeft; RtfKStr: '\headerl' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfHeaderRight; RtfKStr: '\headerr' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfHeaderFirst; RtfKStr: '\headerf' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfFooter; RtfKStr: '\footer' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfFooterLeft; RtfKStr: '\footerl' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfFooterRight; RtfKStr: '\footerr' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfFooterFirst; RtfKStr: '\footerf' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfFNSep; RtfKStr: '\ftnsep' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfFNContSep; RtfKStr: '\ftnsepc' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfFNContNotice; RtfKStr: '\ftncn' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfAnnotation; RtfKStr: '\annotation' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfAnnotID; RtfKStr: '\atnid' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfFieldInst; RtfKStr: '\fldinst' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfFieldResult; RtfKStr: '\fldrslt' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfIndex; RtfKStr: '\xe' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfIndexBold; RtfKStr: '\bxe' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfIndexItalic; RtfKStr: '\ixe' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfIndexText; RtfKStr: '\txe' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfIndexRange; RtfKStr: '\rxe' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfTOC; RtfKStr: '\tc' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfBookmarkStart; RtfKStr: '\bkmkstart' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfBookmarkEnd; RtfKStr: '\bkmkend' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfITitle; RtfKStr: '\title' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfISubject; RtfKStr: '\subject' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfIAuthor; RtfKStr: '\author' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfIOperator; RtfKStr: '\operator' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfIKeywords; RtfKStr: '\keywords' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfIComment; RtfKStr: '\comment' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfIVersion; RtfKStr: '\version' ),
+ (RtfKMajor: RtfDestination; RtfKMinor: RtfIDoccomm; RtfKStr: '\doccomm' ),
+ (RtfKMajor: RtfVersion; RtfKMinor: - 1; RtfKStr: '\rtf' ),
+ (RtfKMajor: RtfDefFont; RtfKMinor: - 1; RtfKStr: '\deff' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfStyleNum; RtfKStr: '\s' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfQuadLeft; RtfKStr: '\ql' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfQuadRight; RtfKStr: '\qr' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfQuadJust; RtfKStr: '\qj' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfQuadCenter; RtfKStr: '\qc' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfFirstIndent; RtfKStr: '\fi' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfLeftIndent; RtfKStr: '\li' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfRightIndent; RtfKStr: '\ri' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfSpaceBefore; RtfKStr: '\sb' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfSpaceAfter; RtfKStr: '\sa' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfSpaceBetween; RtfKStr: '\sl' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfInTable; RtfKStr: '\intbl' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfKeep; RtfKStr: '\keep' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfKeepNext; RtfKStr: '\keepn' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfSideBySide; RtfKStr: '\sbys' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfPBBefore; RtfKStr: '\pagebb' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfNoLineNum; RtfKStr: '\noline' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfTabPos; RtfKStr: '\tx' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfTabRight; RtfKStr: '\tqr' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfTabCenter; RtfKStr: '\tqc' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfTabDecimal; RtfKStr: '\tqdec' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfTabBar; RtfKStr: '\tb' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfBorderTop; RtfKStr: '\brdrt' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfBorderBottom; RtfKStr: '\brdrb' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfBorderLeft; RtfKStr: '\brdrl' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfBorderRight; RtfKStr: '\brdrr' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfBorderBar; RtfKStr: '\bar' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfBorderBox; RtfKStr: '\box' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfBorderBetween; RtfKStr: '\brdrbtw' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfBorderSingle; RtfKStr: '\brdrs' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfBorderThick; RtfKStr: '\brdrth' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfBorderShadow; RtfKStr: '\brdrsh' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfBorderDouble; RtfKStr: '\brdrdb' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfBorderDot; RtfKStr: '\brdrdot' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfBorderHair; RtfKStr: '\brdrhair' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfLeaderDot; RtfKStr: '\tldot' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfLeaderHyphen; RtfKStr: '\tlhyph' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfLeaderUnder; RtfKStr: '\tlul' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfLeaderThick; RtfKStr: '\tlth' ),
+ (RtfKMajor: RtfParAttr; RtfKMinor: RtfBorderSpace; RtfKStr: '\brsp' ),
+ (RtfKMajor: RtfTblAttr; RtfKMinor: RtfCellBordBottom; RtfKStr: '\clbrdrb' ),
+ (RtfKMajor: RtfTblAttr; RtfKMinor: RtfCellBordTop; RtfKStr: '\clbrdrt' ),
+ (RtfKMajor: RtfTblAttr; RtfKMinor: RtfCellBordLeft; RtfKStr: '\clbrdrl' ),
+ (RtfKMajor: RtfTblAttr; RtfKMinor: RtfCellBordRight; RtfKStr: '\clbrdrr' ),
+ (RtfKMajor: RtfTblAttr; RtfKMinor: RtfRowDef; RtfKStr: '\trowd' ),
+ (RtfKMajor: RtfTblAttr; RtfKMinor: RtfRowLeft; RtfKStr: '\trql' ),
+ (RtfKMajor: RtfTblAttr; RtfKMinor: RtfRowRight; RtfKStr: '\trqr' ),
+ (RtfKMajor: RtfTblAttr; RtfKMinor: RtfRowCenter; RtfKStr: '\trqc' ),
+ (RtfKMajor: RtfTblAttr; RtfKMinor: RtfRowGapH; RtfKStr: '\trgaph' ),
+ (RtfKMajor: RtfTblAttr; RtfKMinor: RtfRowHt; RtfKStr: '\trrh' ),
+ (RtfKMajor: RtfTblAttr; RtfKMinor: RtfRowLeftEdge; RtfKStr: '\trleft' ),
+ (RtfKMajor: RtfTblAttr; RtfKMinor: RtfCellPos; RtfKStr: '\cellx' ),
+ (RtfKMajor: RtfTblAttr; RtfKMinor: RtfMergeRngFirst; RtfKStr: '\clmgf' ),
+ (RtfKMajor: RtfTblAttr; RtfKMinor: RtfMergePrevious; RtfKStr: '\clmrg' ),
+ (RtfKMajor: RtfTOCAttr; RtfKMinor: RtfTOCType; RtfKStr: '\tcf' ),
+ (RtfKMajor: RtfTOCAttr; RtfKMinor: RtfTOCLevel; RtfKStr: '\tcl' ),
+ (RtfKMajor: RtfFontFamily; RtfKMinor: RtfFFNil; RtfKStr: '\fnil' ),
+ (RtfKMajor: RtfFontFamily; RtfKMinor: RtfFFRoman; RtfKStr: '\froman' ),
+ (RtfKMajor: RtfFontFamily; RtfKMinor: RtfFFSwiss; RtfKStr: '\fswiss' ),
+ (RtfKMajor: RtfFontFamily; RtfKMinor: RtfFFModern; RtfKStr: '\fmodern' ),
+ (RtfKMajor: RtfFontFamily; RtfKMinor: RtfFFScript; RtfKStr: '\fscript' ),
+ (RtfKMajor: RtfFontFamily; RtfKMinor: RtfFFDecor; RtfKStr: '\fdecor' ),
+ (RtfKMajor: RtfFontFamily; RtfKMinor: RtfFFTech; RtfKStr: '\ftech' ),
+ (RtfKMajor: RtfCharSet; RtfKMinor: RtfMacCharSet; RtfKStr: '\mac' ),
+ (RtfKMajor: RtfCharSet; RtfKMinor: RtfAnsiCharSet; RtfKStr: '\ansi' ),
+ (RtfKMajor: RtfCharSet; RtfKMinor: RtfPcCharSet; RtfKStr: '\pc' ),
+ (RtfKMajor: RtfCharSet; RtfKMinor: RtfPcaCharSet; RtfKStr: '\pca' ),
+ (RtfKMajor: RtfCharAttr; RtfKMinor: RtfPlain; RtfKStr: '\plain' ),
+ (RtfKMajor: RtfCharAttr; RtfKMinor: RtfBold; RtfKStr: '\b' ),
+ (RtfKMajor: RtfCharAttr; RtfKMinor: RtfItalic; RtfKStr: '\i' ),
+ (RtfKMajor: RtfCharAttr; RtfKMinor: RtfStrikeThru; RtfKStr: '\strike' ),
+ (RtfKMajor: RtfCharAttr; RtfKMinor: RtfOutline; RtfKStr: '\outl' ),
+ (RtfKMajor: RtfCharAttr; RtfKMinor: RtfShadow; RtfKStr: '\shad' ),
+ (RtfKMajor: RtfCharAttr; RtfKMinor: RtfSmallCaps; RtfKStr: '\scaps' ),
+ (RtfKMajor: RtfCharAttr; RtfKMinor: RtfAllCaps; RtfKStr: '\caps' ),
+ (RtfKMajor: RtfCharAttr; RtfKMinor: RtfInvisible; RtfKStr: '\v' ),
+ (RtfKMajor: RtfCharAttr; RtfKMinor: RtfFontNum; RtfKStr: '\f' ),
+ (RtfKMajor: RtfCharAttr; RtfKMinor: RtfFontSize; RtfKStr: '\fs' ),
+ (RtfKMajor: RtfCharAttr; RtfKMinor: RtfExpand; RtfKStr: '\expnd' ),
+ (RtfKMajor: RtfCharAttr; RtfKMinor: RtfUnderline; RtfKStr: '\ul' ),
+ (RtfKMajor: RtfCharAttr; RtfKMinor: RtfWUnderline; RtfKStr: '\ulw' ),
+ (RtfKMajor: RtfCharAttr; RtfKMinor: RtfDUnderline; RtfKStr: '\uld' ),
+ (RtfKMajor: RtfCharAttr; RtfKMinor: RtfDbUnderline; RtfKStr: '\uldb' ),
+ (RtfKMajor: RtfCharAttr; RtfKMinor: RtfNoUnderline; RtfKStr: '\ulnone' ),
+ (RtfKMajor: RtfCharAttr; RtfKMinor: RtfSuperScript; RtfKStr: '\up' ),
+ (RtfKMajor: RtfCharAttr; RtfKMinor: RtfSubScript; RtfKStr: '\dn' ),
+ (RtfKMajor: RtfCharAttr; RtfKMinor: RtfRevised; RtfKStr: '\revised' ),
+ (RtfKMajor: RtfCharAttr; RtfKMinor: RtfForeColor; RtfKStr: '\cf' ),
+ (RtfKMajor: RtfCharAttr; RtfKMinor: RtfBackColor; RtfKStr: '\cb' ),
+ (RtfKMajor: RtfCharAttr; RtfKMinor: RtfGray; RtfKStr: '\gray' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfFormula; RtfKStr: '\|' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfNoBrkSpace; RtfKStr: '\~' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfNoReqHyphen; RtfKStr: '\-' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfNoBrkHyphen; RtfKStr: '\_' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfOptDest; RtfKStr: '\*' ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfPar; RtfKstr: #10 ),
+ (RtfKMajor: RtfSpecialChar; RtfKMinor: RtfPar; RtfKstr: #13 ),
+ (RtfKMajor: RtfPosAttr; RtfKMinor: RtfPosX; RtfKStr: '\posx' ),
+ (RtfKMajor: RtfPosAttr; RtfKMinor: RtfPosXCenter; RtfKStr: '\posxc' ),
+ (RtfKMajor: RtfPosAttr; RtfKMinor: RtfPosXInside; RtfKStr: '\posxi' ),
+ (RtfKMajor: RtfPosAttr; RtfKMinor: RtfPosXLeft; RtfKStr: '\posxl' ),
+ (RtfKMajor: RtfPosAttr; RtfKMinor: RtfPosXOutSide; RtfKStr: '\posxo' ),
+ (RtfKMajor: RtfPosAttr; RtfKMinor: RtfPosXRight; RtfKStr: '\posxr' ),
+ (RtfKMajor: RtfPosAttr; RtfKMinor: RtfPosY; RtfKStr: '\posy' ),
+ (RtfKMajor: RtfPosAttr; RtfKMinor: RtfPosYInline; RtfKStr: '\posyil' ),
+ (RtfKMajor: RtfPosAttr; RtfKMinor: RtfPosYTop; RtfKStr: '\posyt' ),
+ (RtfKMajor: RtfPosAttr; RtfKMinor: RtfPosYCenter; RtfKStr: '\posyc' ),
+ (RtfKMajor: RtfPosAttr; RtfKMinor: RtfPosYBottom; RtfKStr: '\posyb' ),
+ (RtfKMajor: RtfPosAttr; RtfKMinor: RtfAbsWid; RtfKStr: '\absw' ),
+ (RtfKMajor: RtfPosAttr; RtfKMinor: RtfTextDist; RtfKStr: '\dxfrtext' ),
+ (RtfKMajor: RtfPosAttr; RtfKMinor: RtfRPosMargV; RtfKStr: '\pvmrg' ),
+ (RtfKMajor: RtfPosAttr; RtfKMinor: RtfRPosPageV; RtfKStr: '\pvpg' ),
+ (RtfKMajor: RtfPosAttr; RtfKMinor: RtfRPosMargH; RtfKStr: '\phmrg' ),
+ (RtfKMajor: RtfPosAttr; RtfKMinor: RtfRPosPageH; RtfKStr: '\phpg' ),
+ (RtfKMajor: RtfPosAttr; RtfKMinor: RtfRPosColH; RtfKStr: '\phcol' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfSectDef; RtfKStr: '\sectd' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfNoBreak; RtfKStr: '\sbknone' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfColBreak; RtfKStr: '\sbkcol' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfPageBreak; RtfKStr: '\sbkpage' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfEvenBreak; RtfKStr: '\sbkeven' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfOddBreak; RtfKStr: '\sbkodd' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfPageCont; RtfKStr: '\pgncont' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfPageStarts; RtfKStr: '\pgnstarts' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfPageRestart; RtfKStr: '\pgnrestart' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfPageDecimal; RtfKStr: '\pgndec' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfPageURoman; RtfKStr: '\pgnucrm' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfPageLRoman; RtfKStr: '\pgnlcrm' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfPageULetter; RtfKStr: '\pgnucltr' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfPageLLetter; RtfKStr: '\pgnlcltr' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfPageNumLeft; RtfKStr: '\pgnx' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfPageNumTop; RtfKStr: '\pgny' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfHeaderY; RtfKStr: '\headery' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfFooterY; RtfKStr: '\footery' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfLineModulus; RtfKStr: '\linemod' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfLineDist; RtfKStr: '\linex' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfLineStarts; RtfKStr: '\linestarts' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfLineRestart; RtfKStr: '\linerestart' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfLineRestartPg; RtfKStr: '\lineppage' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfLineCont; RtfKStr: '\linecont' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfTopVAlign; RtfKStr: '\vertalt' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfBottomVAlign; RtfKStr: '\vertal' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfCenterVAlign; RtfKStr: '\vertalc' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfJustVAlign; RtfKStr: '\vertalj' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfColumns; RtfKStr: '\cols' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfColumnSpace; RtfKStr: '\colsx' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfColumnLine; RtfKStr: '\linebetcol' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfENoteHere; RtfKStr: '\endnhere' ),
+ (RtfKMajor: RtfSectAttr; RtfKMinor: RtfTitleSpecial; RtfKStr: '\titlepg' )
+ (RtfKMajor: RtfFieldAttr; RtfKMinor: RtfFieldDirty; RtfKStr: '\flddirty' ),
+ (RtfKMajor: RtfFieldAttr; RtfKMinor: RtfFieldEdited; RtfKStr: '\fldedit' ),
+ (RtfKMajor: RtfFieldAttr; RtfKMinor: RtfFieldLocked; RtfKStr: '\fldlock' ),
+ (RtfKMajor: RtfFieldAttr; RtfKMinor: RtfFieldPrivate; RtfKStr: '\fldpriv' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfPaperWidth; RtfKStr: '\paperw' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfPaperHeight; RtfKStr: '\paperh' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfLeftMargin; RtfKStr: '\margl' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfRightMargin; RtfKStr: '\margr' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfTopMargin; RtfKStr: '\margt' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfBottomMargin; RtfKStr: '\margb' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfFacingPage; RtfKStr: '\facingp' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfGutterWid; RtfKStr: '\gutter' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfDefTab; RtfKStr: '\deftab' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfWidowCtrl; RtfKStr: '\widowctrl' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfHyphHotZone; RtfKStr: '\hyphhotz' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfFNoteEndSect; RtfKStr: '\endnotes' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfFNoteEndDoc; RtfKStr: '\enddoc' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfFNoteBottom; RtfKStr: '\ftnbj' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfFNoteText; RtfKStr: '\ftntj' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfFNoteStart; RtfKStr: '\ftnstart' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfFNoteRestart; RtfKStr: '\ftnrestart' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfPageStart; RtfKStr: '\pgnstart' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfLineStart; RtfKStr: '\linestart' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfLandscape; RtfKStr: '\landscape' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfFracWidth; RtfKStr: '\fracwidth' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfNextFile; RtfKStr: '\nextfile' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfTemplate; RtfKStr: '\template' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfMakeBackup; RtfKStr: '\makeback' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfRtfDefault; RtfKStr: '\defformat' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfRevisions; RtfKStr: '\revisions' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfMirrorMargin; RtfKStr: '\margmirror' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfRevDisplay; RtfKStr: '\revprop' ),
+ (RtfKMajor: RtfDocAttr; RtfKMinor: RtfRevBar; RtfKStr: '\revbar' ),
+ (RtfKMajor: RtfStyleAttr; RtfKMinor: RtfBasedOn; RtfKStr: '\sbasedon' ),
+ (RtfKMajor: RtfStyleAttr; RtfKMinor: RtfNext; RtfKStr: '\snext' ),
+ (RtfKMajor: RtfColorName; RtfKMinor: RtfRed; RtfKStr: '\red' ),
+ (RtfKMajor: RtfColorName; RtfKMinor: RtfGreen; RtfKStr: '\green' ),
+ (RtfKMajor: RtfColorName; RtfKMinor: RtfBlue; RtfKStr: '\blue' ),
+ (RtfKMajor: RtfPictAttr; RtfKMinor: RtfMacQD; RtfKStr: '\macpict' ),
+ (RtfKMajor: RtfPictAttr; RtfKMinor: RtfWinMetafile; RtfKStr: '\wmetafile' ),
+ (RtfKMajor: RtfPictAttr; RtfKMinor: RtfWinBitmap; RtfKStr: '\wbitmap' ),
+ (RtfKMajor: RtfPictAttr; RtfKMinor: RtfPicWid; RtfKStr: '\picw' ),
+ (RtfKMajor: RtfPictAttr; RtfKMinor: RtfPicHt; RtfKStr: '\pich' ),
+ (RtfKMajor: RtfPictAttr; RtfKMinor: RtfPicGoalWid; RtfKStr: '\picwgoal' ),
+ (RtfKMajor: RtfPictAttr; RtfKMinor: RtfPicGoalWid; RtfKStr: '\picwGoal' ),
+ (RtfKMajor: RtfPictAttr; RtfKMinor: RtfPicGoalHt; RtfKStr: '\pichgoal' ),
+ (RtfKMajor: RtfPictAttr; RtfKMinor: RtfPicGoalHt; RtfKStr: '\pichGoal' ),
+ (RtfKMajor: RtfPictAttr; RtfKMinor: RtfPicScaleX; RtfKStr: '\picscalex' ),
+ (RtfKMajor: RtfPictAttr; RtfKMinor: RtfPicScaleY; RtfKStr: '\picscaley' ),
+ (RtfKMajor: RtfPictAttr; RtfKMinor: RtfPicScaled; RtfKStr: '\picscaled' ),
+ (RtfKMajor: RtfPictAttr; RtfKMinor: RtfPicCropTop; RtfKStr: '\piccropt' ),
+ (RtfKMajor: RtfPictAttr; RtfKMinor: RtfPicCropBottom; RtfKStr: '\piccropb' ),
+ (RtfKMajor: RtfPictAttr; RtfKMinor: RtfPicCropLeft; RtfKStr: '\piccropl' ),
+ (RtfKMajor: RtfPictAttr; RtfKMinor: RtfPicCropRight; RtfKStr: '\piccropr' ),
+ (RtfKMajor: RtfPictAttr; RtfKMinor: RtfPixelBits; RtfKStr: '\wbmbitspixel' ),
+ (RtfKMajor: RtfPictAttr; RtfKMinor: RtfBitmapPlanes; RtfKStr: '\wbmplanes' ),
+ (RtfKMajor: RtfPictAttr; RtfKMinor: RtfBitmapWid; RtfKStr: '\wbmwidthbytes'),
+ (RtfKMajor: RtfPictAttr; RtfKMinor: RtfPicBinary; RtfKStr: '\bin' ),
+ (RtfKMajor: RtfNeXTGrAttr; RtfKMinor: RtfNeXTGWidth; RtfKStr: '\width' ),
+ (RtfKMajor: RtfNeXTGrAttr; RtfKMinor: RtfNeXTGHeight; RtfKStr: '\height' ),
+ }
+ {@indent on}
+
+const
+ TRtfAnyType: TRtfTokenSet =[etDataset..etLitTrue];
+
+function ExtractFieldName(const Fields: string; var Pos: integer): string;
+var i: integer;
+begin
+ i := Pos;
+ while(i <= Length(Fields))and(Fields[i] <> '.')do Inc(i);
+ Result := Trim(Copy(Fields, Pos, i - Pos));
+ if(i <= Length(Fields))and(Fields[i] = '.')
+ then Inc(i);
+ Pos := i;
+end;
+
+function Pwr(const Base, Exponent: Double): Double;
+begin
+ if Exponent = 0.0 then
+ Result := 1.0 { n**0 = 1 }
+ else if(Base = 0.0)and(Exponent > 0.0) then
+ Result := 0.0 { 0**n = 0, n > 0 }
+ else if (Frac(Exponent) = 0.0) and (Abs(Exponent) <= MaxInt) then
+ Result := IntPower(Base, integer(Trunc(Exponent)))
+ else
+ Result := Exp(Exponent * Ln(Base))
+end;
+
+{ TRtfPictureAttr }
+
+constructor TRtfPictureAttr.Create(AWidth, AHeigth: word);
+begin
+ inherited Create;
+ FScaleX := 100;
+ FScaleY := 100;
+ FWidth := AWidth;
+ FHeigth := AHeigth;
+ FWidthmm := AWidth * 0.264596930676;
+ FHeigthmm := AHeigth * 0.264596930676;
+
+ FBorderWidth := 0;
+ FBorderType := brNone;
+ FBorderColor := clBlack;
+ FProportional := true;
+end;
+
+procedure TRtfPictureAttr.SetScaleX(Value: integer);
+var
+ AScale: Double;
+begin
+ if Value < 1 then
+ Value := 1
+ else if Value > 100 then
+ Value := 100;
+ AScale := Double(Value) / FScaleX;
+ FScaleX := Value;
+ FWidth := Round(FWidth * AScale);
+ FWidthmm := FWidthmm * AScale;
+ if FProportional then
+ begin
+ FScaleY := Round(FScaleY * AScale);
+ FHeigth := Round(FHeigth * AScale);
+ FHeigthmm := FHeigthmm * AScale;
+ end;
+end;
+
+procedure TRtfPictureAttr.SetScaleY(Value: integer);
+var
+ AScale: Double;
+begin
+ if Value < 1 then
+ Value := 1
+ else if Value > 100 then
+ Value := 100;
+ AScale := Double(Value) / FScaleY;
+ FScaleY := Value;
+ FHeigth := Round(FHeigth * AScale);
+ FHeigthmm := FHeigthmm * AScale;
+ if FProportional then
+ begin
+ FScaleX := Round(FScaleX * AScale);
+ FWidth := Round(FWidth * AScale);
+ FWidthmm := FWidthmm * AScale;
+ end;
+end;
+
+
+{ TRtfItem }
+
+procedure TRtfItem.Assign(ASource: TRtfItem);
+begin
+ RtfClass := ASource.RtfClass;
+ RtfMajor := ASource.RtfMajor;
+ RtfMinor := ASource.RtfMinor;
+ RtfTextBuf := ASource.RtfTextBuf;
+end;
+
+function TRtfItem.CheckItem(AClass: TRtfClass; Major: integer): boolean;
+begin
+ Result :=(RtfClass = AClass)and(RtfMajor = Major);
+end;
+
+function TRtfItem.GetItem(Index: integer): TRtfItem;
+begin
+ Result := TRtfItem(inherited Items[Index]);
+end;
+
+procedure TRtfItem.Notify(Ptr: pointer; Action: TListNotification);
+begin
+ inherited;
+ case Action of
+ lnAdded: TRtfItem(Ptr).FParent := Self;
+ lnExtracted: TRtfItem(Ptr).FParent := nil;
+ end;
+end;
+
+{ TRtfItemList }
+
+constructor TRtfItemList.Create;
+//Initialize an empty list
+begin
+ inherited Create;
+end;
+
+destructor TRtfItemList.Destroy;
+{-Destroy a list}
+var n: TRtfItem;
+ p: TRtfItem;
+begin
+ n := FTail;
+ while n <> nil do begin
+ {Get TRtfItem to previous node}
+ p := n.FPrev;
+ {Deallocate and destroy this node}
+ n.Free;
+ {Do the previous node}
+ n := p;
+ end;
+ FTail := nil;
+ FHead := nil;
+ FCount := 0;
+ inherited Destroy;
+end;
+
+function TRtfItemList.Add(AItem: TRtfItem): TRtfItem;
+{-Add element to end of list}
+begin
+ Result := AItem;
+ {Exit for bad input}
+ if AItem = nil
+ then Exit;
+ AItem.FPrev := FTail;
+ AItem.FNext := nil;
+ if FHead = nil then begin
+ {Special case for first node}
+ FHead := AItem;
+ FTail := AItem;
+ end else begin
+ {Add at end of existing list}
+ FTail.FNext := AItem;
+ FTail := AItem;
+ end;
+ Inc(FCount);
+end;
+
+procedure TRtfItemList.Insert(AItem: TRtfItem);
+{-Insert element at start of list}
+begin
+ {Exit for bad input}
+ if AItem = nil
+ then Exit;
+ AItem.FPrev := nil;
+ AItem.FNext := FHead;
+ if FHead = nil
+ then FTail := AItem {Special case for first node}
+ else FHead.FPrev := AItem; {Add at start of existing list}
+ FHead := AItem;
+ Inc(FCount);
+end;
+
+procedure TRtfItemList.PlaceAfter(AItem: TRtfItem; AAfter: TRtfItem);
+{-Place element P into list _after_ existing element L}
+begin
+ {Exit for bad input}
+ if(AItem = nil)or(AItem = AAfter)
+ then Exit;
+ if AAfter = nil
+ then Insert(AItem)
+ else if AAfter = FTail
+ then Add(AItem)
+ else begin
+ AItem.FPrev := AAfter;
+ AItem.FNext := AAfter.FNext;
+ AAfter.FNext.FPrev := AItem;
+ AAfter.FNext := AItem;
+ Inc(FCount);
+ end;
+end;
+
+procedure TRtfItemList.PlaceBefore(AItem, ABefore: TRtfItem);
+{-Place element P into list _before_ existing element L}
+begin
+ {Exit for bad input}
+ if(AItem = nil)or(AItem = ABefore)
+ then Exit;
+ if(ABefore = nil)or(ABefore = Head)
+ then Insert(AItem) {Place the new element at the start of the list}
+ else begin
+ {Patch in the new element}
+ AItem.FNext := ABefore;
+ AItem.FPrev := ABefore.FPrev;
+ ABefore.FPrev.FNext := AItem;
+ ABefore.FPrev := AItem;
+ Inc(FCount);
+ end;
+end;
+
+procedure TRtfItemList.dlRemove(AItem: TRtfItem; DisposeIt: boolean);
+{-Delete existing node from list, optionally disposing of it}
+var This: TRtfItem;
+begin
+ {Exit for bad input}
+ if(AItem = nil)or(FCount = 0)
+ then Exit;
+
+ This := AItem;
+ with This do begin
+ {Fix pointers of surrounding nodes}
+ if FNext <> nil
+ then FNext.FPrev := FPrev;
+ if FPrev <> nil
+ then FPrev.FNext := FNext;
+ end;
+
+ {Fix head and tail of list}
+ if FTail = This
+ then FTail := FTail.FPrev;
+ if FHead = This
+ then FHead := FHead.FNext;
+
+ Dec(FCount);
+ if DisposeIt
+ then This.Free;
+end;
+
+procedure TRtfItemList.Extract(AItem: TRtfItem);
+{-Extract existing element from list without disposing of it}
+begin
+ dlRemove(AItem, false);
+end;
+
+procedure TRtfItemList.Delete(AItem: TRtfItem);
+{-Delete an existing node, disposing of its contents}
+begin
+ dlRemove(AItem, true);
+end;
+
+procedure TRtfItemList.Clear;
+begin
+ while Assigned(FHead)do begin
+ dlRemove(FHead, true);
+ end;
+end;
+
+procedure TRtfItemList.SaveToStream(AStream: TStream; AColors: string);
+var AItem: TRtfItem;
+ ALine: string;
+begin
+ AItem := Head;
+ while Assigned(AItem)do begin
+ if AItem.CheckItem(RtfControl, RtfDestination)and(AItem.RtfMinor = RtfColorTbl)
+ then ALine := Format('\colortbl;%s}',[AColors])
+ else ALine := AItem.RtfTextBuf;
+ if ALine <> ''
+ then AStream.Write(ALine[1], Length(ALine));
+ AItem := AItem.Next;
+ end;
+end;
+
+{ TRawRtfParser }
+
+procedure TRawRtfParser.RtfHook;
+//Build a tree from the rtf-code tokens
+var AItem: TRtfItem;
+
+
+ function NewItem(AText: string): TRtfItem;
+ begin
+ Result := TRtfItem.Create;
+ Result.RtfClass := RtfClass;
+ Result.RtfMajor := RtfMajor;
+ Result.RtfMinor := RtfMinor;
+ Result.RtfTextBuf := AText;
+ end;
+begin
+ case RtfClass of
+ RtfParseBegin: begin
+ if Assigned(AParseItem) then begin
+ //Then close it
+ AParseItem := nil;
+ AItem := RawItems.Add(NewItem(''));
+ AItem.RtfClass := RtfParseEnd;
+ end else begin
+ //Otherwise open an item
+ AParseItem := RawItems.Add(NewItem(''));
+ AParseItem.RtfClass := RtfParseBegin;
+ end;
+ end;
+ RtfControl: begin
+ if(RtfMajor = RtfDestination)and(RtfMinor = RtfColorTbl)
+ then FColorTable := RawItems.Add(NewItem(RtfTextBuf))
+ else RawItems.Add(NewItem(RtfTextBuf));
+ end;
+ RtfText: begin
+ if RawItems.Tail.RtfClass = RtfClass
+ then RawItems.Tail.RtfTextBuf := RawItems.Tail.RtfTextBuf + RtfTextBuf
+ else RawItems.Add(NewItem(RtfTextBuf));
+ end;
+ RtfGroup, RtfUnknown: begin
+ if RawItems.Tail.RtfClass in[RtfGroup, RtfUnknown]
+ then RawItems.Tail.RtfTextBuf := RawItems.Tail.RtfTextBuf + RtfTextBuf
+ else RawItems.Add(NewItem(RtfTextBuf));
+ RawItems.Tail.RtfClass := RtfUnknown; //Dont use these for compares
+ end;
+ end;
+end;
+
+function TRawRtfParser.GetRtfChar: char;
+begin
+ if APtr >= AEnd
+ then Result := #0
+ else begin
+ Result := APtr^;
+ Inc(APtr);
+ end;
+end;
+
+procedure TRawRtfParser.GetRtfToken;
+var c: char;
+ i, ALevel: integer;
+begin
+ FRtfTextBuf := ''; //not really needed
+
+ //Get first character, which may be a pushback from previous token
+ if APushedChar <> #0 then begin
+ c := APushedChar;
+ APushedChar := #0;
+ end
+ else c := GetRtfChar;
+
+
+ case c of
+ #0: begin
+ FRtfClass := RtfEof;
+ FRtfTextBuf := '';
+ end;
+ #8: begin //effectively a \tab control symbol
+ FRtfClass := RtfControl;
+ FRtfMajor := RtfSpecialChar;
+ FRtfMinor := RtfTab;
+ FRtfTextBuf := c;
+ c := #0;
+ end;
+ '{': begin
+ FRtfClass := RtfGroup;
+ FRtfMajor := RtfBeginGroup;
+ FRtfTextBuf := c;
+ c := #0;
+ end;
+ '}': begin
+ FRtfClass := RtfGroup;
+ FRtfMajor := RtfEndGroup;
+ FRtfTextBuf := c;
+ c := #0;
+ end;
+ '\': begin //We have the backslash, advance to next character
+ FRtfTextBuf := c;
+ c := GetRtfChar;
+ case c of
+ chr(39): begin //Hex encoded text char, e.g., \'d5, \'d3
+ FRtfClass := RtfUnknown;
+ FRtfTextBuf := FRtfTextBuf + c;
+ c := GetRtfChar;
+ if c <> #0 then begin
+ FRtfTextBuf := FRtfTextBuf + c;
+ c := GetRtfChar;
+ if c <> #0 then begin
+ FRtfClass := RtfText;
+ FRtfTextBuf := FRtfTextBuf + c;
+ //It can still be a special character..
+ for i := Low(Rtfkey)to High(Rtfkey)do begin
+ if FRtfTextBuf = Rtfkey[i].RtfKStr then begin
+ FRtfClass := RtfControl;
+ FRtfMajor := Rtfkey[i].RtfKMajor;
+ FRtfMinor := Rtfkey[i].RtfKMinor;
+ break;
+ end;
+ end;
+ c := #0;
+ end;
+ end;
+ end;
+ ':', '{', '}', ';', '\': begin //special escaped text char, e.g., \, \;
+ FRtfTextBuf := FRtfTextBuf + c;
+ //"\" Marks the start and end of an expression with the RtfParseBegin
+ //RtfClass. They will later be removed and replaced by RtfExpression
+ //Items between the opening and closing \ will be the expression text
+ if c = '\'
+ then FRtfClass := RtfParseBegin
+ else FRtfClass := RtfText;
+ c := #0;
+ end;
+ '|': begin
+ FRtfTextBuf := FRtfTextBuf + c;
+ FRtfClass := RtfControl;
+ FRtfMajor := RtfSpecialChar;
+ FRtfMinor := RtfFormula;
+ c := #0;
+ end;
+ '~': begin
+ FRtfTextBuf := FRtfTextBuf + c;
+ FRtfClass := RtfControl;
+ FRtfMajor := RtfSpecialChar;
+ FRtfMinor := RtfNoBrkSpace;
+ c := #0;
+ end;
+ '-': begin
+ FRtfTextBuf := FRtfTextBuf + c;
+ FRtfClass := RtfControl;
+ FRtfMajor := RtfSpecialChar;
+ FRtfMinor := RtfNoReqHyphen;
+ c := #0;
+ end;
+ '_': begin
+ FRtfTextBuf := FRtfTextBuf + c;
+ FRtfClass := RtfControl;
+ FRtfMajor := RtfSpecialChar;
+ FRtfMinor := RtfNoBrkHyphen;
+ c := #0;
+ end;
+ '*': begin
+ FRtfTextBuf := FRtfTextBuf + c;
+ FRtfClass := RtfControl;
+ FRtfMajor := RtfSpecialChar;
+ FRtfMinor := RtfOptDest;
+ c := #0;
+ end;
+ #13, #10: begin
+ FRtfTextBuf := FRtfTextBuf + c;
+ FRtfClass := RtfControl;
+ FRtfMajor := RtfSpecialChar;
+ FRtfMinor := RtfPar;
+ c := #0;
+ end;
+ else begin //Wasn't anything special, continue with control word
+
+ while(c in['A'..'Z', 'a'..'z'])do begin
+ FRtfTextBuf := FRtfTextBuf + c;
+ c := GetRtfChar;
+ end;
+
+ //Find the control word in the key array
+ FRtfClass := RtfUnknown;
+ for i := Low(Rtfkey)to High(Rtfkey)do begin
+ if FRtfTextBuf = Rtfkey[i].RtfKStr then begin
+ FRtfClass := RtfControl;
+ FRtfMajor := Rtfkey[i].RtfKMajor;
+ FRtfMinor := Rtfkey[i].RtfKMinor;
+ break;
+ end;
+ end;
+
+ //Parse the word parameter negative sign
+ if c = '-' then begin
+ FRtfTextBuf := FRtfTextBuf + c;
+ c := GetRtfChar;
+ end;
+ //Parse the word parameter number
+ while(c in['0'..'9'])do begin
+ FRtfTextBuf := FRtfTextBuf + c;
+ c := GetRtfChar;
+ end;
+
+ //Append control symbol delimiter (i need it for writing)
+ if c = ' ' then begin
+ FRtfTextBuf := FRtfTextBuf + c;
+ c := GetRtfChar;
+ end;
+
+ //Crap1: Fix for {\field{\*\fldinst SYMBOL 32 \\f "Symbol" \\s 12}{\fldrslt\...
+ //RTF text gets corrupted by this parser (notice the Double backslash!)
+ //Crap2:Also INFO since it can contain the first line from rtf as docinfo.
+ if(FRtfClass = RtfControl)and(FRtfMajor = RtfDestination) then begin
+ if FRtfMinor in[RtfField, RtfInfo, RtfStyleSheet, RtfFontTbl, RtfColorTbl] then begin
+ //Just include the whole field Group to the TextBuf (who cares..?)
+ ALevel := 1; //All these items have a "group open" before them
+ while c <> #0 do begin
+ FRtfTextBuf := FRtfTextBuf + c;
+ case c of
+ '{': Inc(ALevel);
+ '}': Dec(ALevel);
+ end;
+ c := GetRtfChar;
+ if ALevel = 0
+ then break;
+ end;
+ FRtfClass := RtfControl;
+ end;
+ end;
+ end;
+ end;
+ end;
+ else
+ begin
+ //literal text char. This will give one character per call (which is slow)
+ FRtfTextBuf := c;
+ FRtfClass := RtfText;
+
+ c := GetRtfChar;
+ while not(c in[#0, #8, '\', '{', '}']) do
+ begin
+ FRtfTextBuf := FRtfTextBuf + c;
+ c := GetRtfChar;
+ end;
+ end;
+ end;
+
+ //Push character back if we read one to much
+ if c <> #0 then
+ APushedChar := c;
+end;
+
+procedure TRawRtfParser.Execute(ARawItems: TRtfItemList; ARtfPtr: pchar; ARtfSize: integer);
+var AItem: TRtfItem;
+begin
+ APtr := ARtfPtr;
+ APushedChar := #0;
+ RawItems := ARawItems;
+ FRtfClass := RtfNothing;
+ AEnd := APtr + ARtfSize;
+
+ //Dummy item so tail of list is always assigned
+ AItem := TRtfItem.Create;
+ AItem.RtfClass := RtfText;
+ ARawItems.Add(AItem);
+
+ while true do
+ begin
+ GetRtfToken;
+ if RtfClass = RtfEOF then
+ break;
+ RtfHook;
+ end;
+end;
+
+{ TRtfVariableList }
+
+function TRtfVariableList.Add(AName: string; AValue: variant; AToken: TRtfToken): TRtfVariable;
+begin
+ Result := Find(AName);
+ if Assigned(Result) then
+ raise TRtfException.CreateFmt('Variable %s already exists',[AName]);
+ Result := TRtfVariable.Create;
+ inherited Add(Result);
+ Result.Name := AName;
+ Result.Value := AValue;
+ Result.Token := AToken;
+end;
+
+destructor TRtfVariableList.Destroy;
+begin
+ inherited;
+end;
+
+function TRtfVariableList.Find(AName: string): TRtfVariable;
+var i: integer;
+begin
+ for i := 0 to Count - 1 do begin
+ Result := Items[i];
+ if SameText(Result.Name, AName)
+ then exit;
+ end;
+ Result := nil;
+end;
+
+function TRtfVariableList.GetItem(Index: integer): TRtfVariable;
+begin
+ Result := TRtfVariable(inherited Items[Index]);
+end;
+
+{ TRtfFunctionList }
+
+function TRtfFunctionList.GetItem(Index: integer): TRtfFunction;
+begin
+ Result := TRtfFunction(inherited Items[Index]);
+end;
+
+function TRtfFunctionList.Add(ATokenType: TRtfToken; AName: string; AMin, AMax: smallint; AOnexecute: TRtfFunctionExecute): TRtfFunction;
+//Add a new function or even an additional token to the function list
+begin
+ Result := Find(AName);
+ if Assigned(Result)
+ then raise TRtfException.CreateFmt('Function already exists',[AName]);
+
+ Result := TRtfFunction.Create;
+ Result.Name := AName;
+ Result.Min := AMin;
+ Result.Max := AMax;
+ Result.Token := ATokenType;
+ Result.Onexecute := AOnexecute;
+ inherited Add(Result);
+end;
+
+function TRtfFunctionList.Find(AName: string): TRtfFunction;
+var i: integer;
+begin
+ for i := 0 to Count - 1 do begin
+ Result := Items[i];
+ if SameText(Result.Name, AName)
+ then exit;
+ end;
+ Result := nil;
+end;
+
+{ TRtfDataset }
+
+procedure TRtfDataset.Notify(Ptr: pointer; Action: TListNotification);
+begin
+ inherited;
+ case Action of
+ lnAdded: TRtfDataset(Ptr).FParent := Self;
+ lnExtracted: TRtfDataset(Ptr).FParent := nil;
+ end;
+end;
+
+function TRtfDataset.Bof: boolean;
+begin
+ if Dataset is TDataset then begin
+ with Dataset as TDataset do begin
+ Result := Bof;
+ end
+ end
+ else if Dataset is TtiObjectList then
+ Result := TableIndex = 0
+ else if Dataset is TtiObject then
+ Result := false
+ else
+ raise TRtfException.Create(rsNotImplemented);
+end;
+
+function TRtfDataset.Eof: boolean;
+begin
+ if Dataset is TDataset then begin
+ with Dataset as TDataset do begin
+ Result := Eof;
+ end
+ end
+ else if Dataset is TtiObjectList then
+ Result :=(TableIndex >= RecordCount)or(TableIndex < 0)
+ else if Dataset is TtiObject then
+ Result := false
+ else
+ Result := false;
+end;
+
+function TRtfDataset.Find(AName: string): TRtfDataset;
+var i: integer;
+begin
+ for i := 0 to Count - 1 do begin
+ Result := Items[i];
+ if SameText(Result.Name, AName)
+ then exit;
+ end;
+ Result := nil;
+end;
+
+function TRtfDataset.Add(ADataset: TObject; AName: string; AFreeDataset: boolean = false): TRtfDataset;
+begin
+ Result := Find(AName);
+ if Assigned(Result) then
+ raise TRtfException.CreateFmt('Dataset already exists',[AName]);
+
+ Result := TRtfDataset.Create;
+ Result.Dataset := ADataset;
+ Result.Name := AName;
+ Result.FFreeDataset := AFreeDataset;
+ inherited Add(Result);
+end;
+
+function TRtfDataset.ResolveNestedFields(ATable: TRtfDataset; AName: string; var AFieldName: string): TRtfDataset;
+//Advance to field level (skipping nested dataset objects)
+var ATableName: string;
+ APropInfo: PPropInfo;
+ ASubTable: TRtfDataset;
+ AIndex, i: integer;
+ AObject: TObject;
+begin
+ AIndex := 1;
+ Result := ATable;
+ AFieldName := AName;
+ while AIndex < Length(AName)do begin
+
+ //Check object dataset and eof state
+ AObject := nil;
+ if Result.Dataset is TDataset
+ then exit; //A TDataset is never nested
+ if Result.Dataset is TtiObjectList then begin
+ //Get the right record from the array
+ if Result.TableIndex <(Result.Dataset as TtiObjectList).Count
+ then AObject :=(Result.Dataset as TtiObjectList)[Result.TableIndex]
+ else exit; //Trying beyond eof (or empty table) big problem; nah?
+ end else if Result.Dataset is TtiObject
+ then AObject := Result.Dataset
+ else raise TRtfException.Create('Unknown object');
+
+ //If the next field is a class then advance
+ ASubTable := nil;
+ ATableName := ExtractFieldName(AName, AIndex);
+ APropInfo := GetPropInfo(AObject, ATableName);
+ if not Assigned(APropInfo)or(APropInfo^.PropType^.Kind <> tkClass)
+ then exit; //As long as it's an object continue parsing..
+
+ //Advance fieldname and find nested table
+ AFieldName := Copy(AName, AIndex, Maxint);
+ for i := 0 to Result.Count - 1 do begin
+ if SameText(Result[i].Name, ATableName) then begin
+ ASubTable := Result[i];
+ break;
+ end;
+ end;
+
+ //Add the nested table (for administration of the TableIndex)
+ if not Assigned(ASubTable) then begin
+ APropInfo := GetPropInfo(AObject, ATableName);
+ if not Assigned(APropInfo)
+ then raise TRtfException.CreateFmt('property %s not found',[ATableName]);
+ if APropInfo^.PropType^.Kind = tkClass
+ then AObject := GetObjectProp(AObject, APropInfo)
+ else exit; //Just a plain property field (returned via AFieldName)
+ ASubTable := Result.Add(AObject, ATableName);
+ end;
+
+ //Advance to a deeper table level
+ Result := ASubTable;
+ end;
+end;
+
+function TRtfDataset.Find(AName: string; var AFieldName: string): TRtfDataset;
+//Find the requested dataset
+var ATableName: string;
+ AIndex, i: integer;
+begin
+ //MainTable must be in the list of tables
+ //Otherwise no point of reference.
+ AIndex := 1;
+ Result := nil;
+ ATableName := ExtractFieldName(AName, AIndex);
+ AFieldName := Copy(AName, AIndex, Maxint);
+ for i := 0 to Count - 1 do begin
+ if SameText(Items[i].Name, ATableName) then begin
+ Result := Items[i];
+ break;
+ end;
+ end;
+ if not Assigned(Result)or not Assigned(Result.Dataset)
+ then raise TRtfException.CreateFmt('Unable to resolve %s',[ATableName]);
+ Result := ResolveNestedFields(Result, AFieldName, AFieldName);
+end;
+
+procedure TRtfDataset.Open;
+begin
+ Clear; //Clear nested tables
+ if Dataset is TDataset then begin
+ with Dataset as TDataset do begin
+ if not Active
+ then Open;
+ end
+ end;
+ First;
+end;
+
+procedure TRtfDataset.First;
+begin
+ Clear; //Clear nested tables
+ if Dataset is TDataset then
+ begin
+ with Dataset as TDataset do
+ begin
+ First;
+ end
+ end
+ else if Dataset is TtiObjectList then
+ begin
+ TableIndex := 0;
+ end;
+end;
+
+function TRtfDataset.GetItem(Index: integer): TRtfDataset;
+begin
+ Result := TRtfDataset(inherited Items[Index]);
+end;
+
+function TRtfDataset.IsEmpty: boolean;
+begin
+ if Dataset is TDataset then
+ begin
+ with Dataset as TDataset do
+ begin
+ Result := IsEmpty;
+ end
+ end
+ else if Dataset is TtiObjectList then
+ Result := RecordCount = 0
+ else if Dataset is TtiObject then
+ Result := false
+ else
+ raise TRtfException.Create(rsNotImplemented);
+end;
+
+procedure TRtfDataset.Last;
+begin
+ Clear; //Clear nested tables
+ if Dataset is TDataset then begin
+ with Dataset as TDataset do begin
+ Last;
+ end
+ end else if Dataset is TtiObjectList then begin
+ TableIndex := RecordCount - 1;
+ end;
+end;
+
+procedure TRtfDataset.Next;
+begin
+ Clear; //Clear nested tables
+ if Dataset is TDataset then begin
+ with Dataset as TDataset do begin
+ Next;
+ end
+ end else if Dataset is TtiObjectList then begin
+ if not Eof then begin
+ TableIndex := TableIndex + 1;
+ end;
+ end;
+end;
+
+procedure TRtfDataset.Prior;
+begin
+ Clear; //Clear nested tables
+ if Dataset is TDataset then begin
+ with Dataset as TDataset do begin
+ Prior;
+ end
+ end else if Dataset is TtiObjectList then begin
+ if not Bof then begin
+ TableIndex := TableIndex - 1;
+ end;
+ end;
+end;
+
+function TRtfDataset.RecordCount: integer;
+//This can give problems with Sql..
+begin
+ if Dataset is TDataset
+ then Result :=(Dataset as TDataset).RecordCount
+ else if Dataset is TtiObjectList
+ then Result :=(Dataset as TtiObjectList).Count
+ else Result := 1; //Single OpfRecord
+end;
+
+destructor TRtfDataset.Destroy;
+begin
+ if FreeDataset
+ then FreeAndNil(FDataset);
+ inherited;
+end;
+
+
+{ TRtfArgument }
+
+constructor TRtfArgument.Create(AParser: TtiRtfParser);
+begin
+ inherited Create(true);
+ FParser := AParser;
+end;
+
+function TRtfArgument.Add(AValue: variant; ATokenType: TRtfToken): TRtfArgument;
+begin
+ Result := TRtfArgument.Create(Parser);
+ inherited Add(Result);
+ Result.Value := AValue;
+ Result.Token := ATokenType;
+end;
+
+function TRtfArgument.Add(AArgument: TRtfArgument): TRtfArgument;
+begin
+ inherited Add(AArgument);
+ Result := AArgument;
+end;
+
+function TRtfArgument.GetItem(Index: integer): TRtfArgument;
+begin
+ Result := TRtfArgument(inherited Items[Index]);
+end;
+
+procedure TRtfArgument.Notify(Ptr: pointer; Action: TListNotification);
+//Nice way of setting the parent reference
+begin
+ inherited;
+ case Action of
+ lnAdded: TRtfArgument(Ptr).FParent := Self;
+ lnExtracted: TRtfArgument(Ptr).FParent := nil;
+ end;
+end;
+
+function TRtfArgument.Check(AParam: integer; ATokens: TRtfTokenSet): boolean;
+begin
+ if AParam >= Count then begin
+ Result := false;
+ exit;
+ end;
+ if not(Items[AParam].Token in ATokens) then begin
+ Result := false;
+ exit;
+ end;
+ Result := true;
+end;
+
+function TRtfArgument.Check(ATokens: array of TRtfTokenSet): boolean;
+var i: integer;
+begin
+ for i := Low(ATokens)to High(ATokens)do begin
+ Result := Check(i, ATokens[i]);
+ if not Result
+ then exit;
+ end;
+ Result := true;
+end;
+
+procedure TRtfArgument.ParseExpression(AExpression: string);
+//Add token to the argument list. Parameters surrounded by parentheses will
+//be added to the nested arguments. This will make a nice argument tree.
+//Constant .9 wont be parse, but that's ok
+var FSourcePtr, p, TokenStart: PChar;
+ ALastArgument, ALast: TRtfArgument;
+ AInts: array[0..6]of integer;
+ ASeps: array[0..6]of char;
+ AFunction: TRtfFunction;
+ AFloatResult: boolean;
+ AIntIndex: integer;
+ AValue: variant;
+ AToken: string;
+begin
+ ALast := nil;
+ Value := varEmpty;
+ Token := etNothing;
+ ALastArgument := Self;
+ FSourcePtr := PChar(AExpression);
+ while FSourcePtr^ <> #0 do begin
+
+ p := FSourcePtr;
+ while(P^ <> #0)and(P^ <= ' ')do begin
+ ALast := nil;
+ Inc(p);
+ end;
+
+ TokenStart := p;
+ case P^ of
+ 'A'..'Z', 'a'..'z', '_', '@': begin //De '@' voor referentie variabelen (nieuw)
+ Inc(p);
+ ALast := nil;
+ while P^ in['A'..'Z', 'a'..'z', '0'..'9', '_', '.', '@']do Inc(p);
+ if TokenStart^ = '@' then begin
+ Inc(TokenStart); //Remove the '@' prefix
+ SetString(AToken, TokenStart, p - TokenStart);
+ ALast := ALastArgument.Add(AToken, etVariable)
+ end else begin
+ SetString(AToken, TokenStart, p - TokenStart);
+ AFunction := Parser.Functions.Find(AToken);
+ if Assigned(AFunction)
+ then ALastArgument.Add(AFunction.Name, AFunction.Token)
+ else ALast := ALastArgument.Add(AToken, etFieldName); //Field or tablename, what else can it be?
+ end;
+ end;
+ Chr(39): begin
+ Inc(p);
+ TokenStart := p;
+ while true do begin
+ if P^ = Chr(39) then begin
+ SetString(AToken, TokenStart, p - TokenStart);
+ //Concatenate etFieldName."Field with spaces"
+ if Assigned(ALast)and(ALast.Token in[etVariable, etFieldName])
+ then ALast.Value := ALast.Value + AToken
+ else ALastArgument.Add(AToken, etLitString);
+ Inc(p);
+ Break;
+ end;
+ if P^ = #0
+ then raise TRtfException.Create(rsUnterminatedStringConstant);
+ Inc(p);
+ end;
+ end;
+ '"': begin
+ Inc(p);
+ TokenStart := p;
+ while true do begin
+ if P^ = '"' then begin
+ SetString(AToken, TokenStart, p - TokenStart);
+ //Concatenate etFieldName."Field with spaces"
+ if Assigned(ALast)and(ALast.Token in[etVariable, etFieldName])
+ then ALast.Value := ALast.Value + AToken
+ else ALastArgument.Add(AToken, etLitString);
+ Inc(p);
+ Break;
+ end;
+ if P^ = #0
+ then raise TRtfException.Create(rsUnterminatedStringConstant);
+ Inc(p);
+ end;
+ end;
+ '-': begin
+ Inc(p);
+ ALast := nil;
+ ALastArgument.Add(AToken, etSUB);
+ end;
+ '0'..'9': begin //Ik ga ervan uit dat alles in het amerikaans genoteerd word
+ Inc(p);
+ ALast := nil;
+ AFloatResult := false;
+ while P^ in['0'..'9']do Inc(p);
+ if P^ = '.' then begin //Floating point
+ Inc(p);
+ AFloatResult := true;
+ while P^ in['0'..'9']do Inc(p);
+ end;
+ if P^ in['e', 'E'] then begin //1.700000E+308
+ AFloatResult := true;
+ Inc(p);
+ if P^ in['+', '-']
+ then Inc(p);
+ while P^ in['0'..'9']do Inc(p);
+ end;
+ SetString(AToken, TokenStart, p - TokenStart);
+ if AFloatResult
+ then AValue := StrToFloat(AToken)
+ else AValue := StrToInt(AToken);
+ if AFloatResult
+ then ALastArgument.Add(AValue, etLitFloat)
+ else ALastArgument.Add(AValue, etLitInt);
+ end;
+ '(': begin
+ Inc(p);
+ ALast := nil;
+ //Add them to the last function if possible..
+ if(ALastArgument.Count > 0)and(ALastArgument[ALastArgument.Count - 1].Token in[etFunction, etProcedure])
+ then ALastArgument := ALastArgument[ALastArgument.Count - 1]
+ else ALastArgument := ALastArgument.Add('()', etParenthesis);
+ end;
+ ')': begin
+ Inc(p);
+ ALast := nil;
+ ALastArgument := ALastArgument.Parent;
+ if not Assigned(ALastArgument)
+ then raise TRtfException.Create(rsToManyClosingParenthesis);
+ end;
+ '<': begin
+ Inc(p);
+ ALast := nil;
+ case P^ of
+ '=': begin
+ Inc(p);
+ ALastArgument.Add('<=', etLE);
+ end;
+ '>': begin
+ Inc(p);
+ ALastArgument.Add('<>', etNE);
+ end;
+ else ALastArgument.Add('<', etLT);
+ end;
+ end;
+ '=': begin
+ Inc(p);
+ ALast := nil;
+ ALastArgument.Add('=', etEq);
+ end;
+ ':': begin
+ Inc(p);
+ ALast := nil;
+ if P^ = '=' then begin
+ Inc(p);
+ ALastArgument.Add(':=', etAssign);
+ end
+ else raise TRtfException.CreateFmt(rsInvalidExpressionCharacter,[P^]);
+ end;
+ '&': begin
+ Inc(p);
+ ALast := nil;
+ if P^ = '&' then begin
+ Inc(p);
+ ALastArgument.Add('and', etAnd);
+ end
+ else raise TRtfException.CreateFmt(rsInvalidExpressionCharacter,[P^]);
+ end;
+ '|': begin
+ Inc(p);
+ ALast := nil;
+ if P^ = '|' then begin
+ Inc(p);
+ ALastArgument.Add('or', etOr);
+ end
+ else raise TRtfException.CreateFmt(rsInvalidExpressionCharacter,[P^]);
+ end;
+ '!': begin
+ Inc(p);
+ ALast := nil;
+ if P^ = '=' then begin
+ Inc(p);
+ ALastArgument.Add('!=', etNe);
+ end
+ else ALastArgument.Add(AToken, etNot);
+ end;
+ '>': begin
+ Inc(p);
+ ALast := nil;
+ if P^ = '=' then begin
+ Inc(p);
+ ALastArgument.Add('>=', etGE);
+ end
+ else ALastArgument.Add('>', etGT);
+ end;
+ '+': begin
+ Inc(p);
+ ALast := nil;
+ ALastArgument.Add('+', etADD);
+ end;
+ '*': begin
+ Inc(p);
+ ALast := nil;
+ ALastArgument.Add('*', etMUL);
+ end;
+ '/': begin
+ Inc(p);
+ ALast := nil;
+ ALastArgument.Add('/', etDIV);
+ end;
+ ',': begin
+ Inc(p);
+ ALast := nil;
+ ALastArgument.Add(',', etComma);
+ end;
+ '\': begin //a date/time constant. Since these are
+ //in a fixed format we need to parse them ourselves.
+ Inc(p);
+ ALast := nil;
+ if P^ = '{' then begin
+ Inc(p);
+ FillChar(AInts[0], SizeOf(AInts), 0);
+ FillChar(ASeps[0], SizeOf(ASeps), 0);
+
+ AIntIndex := 0;
+ while(p^ <> #0)and(p^ in['0'..'9', ' ', ':', '-'])do begin
+ //read integer parts
+ TokenStart := p;
+ while P^ in['0'..'9']do Inc(p);
+ SetString(AToken, TokenStart, p - TokenStart);
+ if AToken = ''
+ then raise TRtfException.Create(rsInvalidDateConstant);
+ ASeps[AIntIndex] := p^;
+ AInts[AIntIndex] := StrToInt(AToken);
+ Inc(AIntIndex);
+ if AIntIndex > 6
+ then raise TRtfException.Create(rsInvalidDateConstant);
+ if(p^ in[' ', '-', ':'])
+ then Inc(p);
+ end;
+
+ //There shoud be at least two values entered
+ if AIntIndex < 2
+ then raise TRtfException.Create(rsInvalidDateConstant);
+
+ if not(p^ in['\'])
+ then raise TRtfException.Create(rsInvalidDateConstant);
+ Inc(p);
+ if P^ <> '}'
+ then raise TRtfException.Create(rsInvalidDateConstant);
+ Inc(p);
+
+ if ASeps[0] = '-' then begin
+ //Its a date/time constant.. There should be at least 3 ints
+ if AIntIndex < 3
+ then raise TRtfException.Create(rsInvalidDateConstant);
+ if ASeps[1] <> '-'
+ then raise TRtfException.Create(rsInvalidDateSeparator);
+ if not(ASeps[2]in[' ', '\'])
+ then raise TRtfException.Create(rsInvalidDateSeparator);
+ AValue := EncodeDate(AInts[0], AInts[1], AInts[2]);
+
+ //Followed by a optional time constant? There should be at least 2 ints in it
+ if AIntIndex > 3 then begin
+ if AIntIndex < 5
+ then raise TRtfException.Create(rsInvalidTimeConstant);
+ if not(ASeps[2]in[' '])
+ then raise TRtfException.Create(rsInvalidTimeSeparator);
+ if not(ASeps[3]in[':', ' ', '\'])
+ then raise TRtfException.Create(rsInvalidTimeSeparator);
+ AValue := AValue + EncodeTime(AInts[3], AInts[4], AInts[5], 0);
+ end;
+ end else if ASeps[0] = ':' then begin
+ //Its a time constant.. There should be at least 2 ints
+ if AIntIndex < 1
+ then raise TRtfException.Create(rsInvalidTimeConstant);
+ if not(ASeps[1]in[':', ' ', '\'])
+ then raise TRtfException.Create(rsInvalidTimeSeparator);
+ AValue := EncodeTime(AInts[0], AInts[1], AInts[2], 0);
+ end;
+ ALastArgument.Add(AValue, etLitDate)
+ end
+ else raise TRtfException.CreateFmt(rsInvalidExpressionCharacter,[P^]);
+ end;
+ else begin
+ if p^ <> #0
+ then raise TRtfException.CreateFmt(rsInvalidExpressionCharacter,[P^]);
+ end;
+ end;
+ FSourcePtr := p;
+ end;
+ if ALastArgument <> Self
+ then raise TRtfException.Create(rsExpectedClosingParenthesis);
+end;
+
+procedure TRtfArgument.EvaluateUnaryBinary(APrevItem, AArgument, ANextItem: TRtfArgument);
+begin
+ case APrevItem.Token of
+ etLitString: begin
+ case ANextItem.Token of
+ etLitString: begin
+ if AArgument.Token <> etAdd
+ then raise TRtfException.Create('Unable to combine strings with other types');
+ APrevItem.Value := APrevItem.Value + ANextItem.Value;
+ Remove(AArgument);
+ Remove(ANextItem);
+ end;
+ else raise TRtfException.Create('Unable to combine strings with other types');
+ end;
+ end;
+ etLitInt: begin
+ case ANextItem.Token of
+ etLitInt, etLitDate, etLitFloat: begin
+ case AArgument.Token of
+ etAdd: APrevItem.Value := APrevItem.Value + ANextItem.Value;
+ etSub: APrevItem.Value := APrevItem.Value - ANextItem.Value;
+ etMul: APrevItem.Value := APrevItem.Value * ANextItem.Value;
+ etDiv: APrevItem.Value := APrevItem.Value / ANextItem.Value;
+ end;
+ if ANextItem.Token = etLitDate
+ then APrevItem.Token := etLitDate
+ else if ANextItem.Token = etLitFloat
+ then APrevItem.Token := etLitFloat
+ else if AArgument.Token = etDiv
+ then APrevItem.Token := etLitFloat
+ else APrevItem.Token := etLitInt;
+ Remove(AArgument);
+ Remove(ANextItem);
+ end;
+ else raise TRtfException.Create('Invalid formula');
+ end;
+ end;
+ etLitFloat: begin
+ case ANextItem.Token of
+ etLitInt, etLitFloat, etLitDate: begin
+ case AArgument.Token of
+ etAdd: APrevItem.Value := APrevItem.Value + ANextItem.Value;
+ etSub: APrevItem.Value := APrevItem.Value - ANextItem.Value;
+ etMul: APrevItem.Value := APrevItem.Value * ANextItem.Value;
+ etDiv: APrevItem.Value := APrevItem.Value / ANextItem.Value;
+ end;
+ if ANextItem.Token = etLitDate
+ then APrevItem.Token := etLitDate
+ else APrevItem.Token := etLitFloat;
+ Remove(AArgument);
+ Remove(ANextItem);
+ end;
+ else raise TRtfException.Create('Invalid formula');
+ end;
+ end;
+ etLitDate: begin
+ case ANextItem.Token of
+ etLitInt, etLitFloat, etLitDate: begin
+ case AArgument.Token of
+ etAdd: APrevItem.Value := APrevItem.Value + ANextItem.Value;
+ etSub: APrevItem.Value := APrevItem.Value - ANextItem.Value;
+ etMul: APrevItem.Value := APrevItem.Value * ANextItem.Value;
+ etDiv: APrevItem.Value := APrevItem.Value / ANextItem.Value;
+ end;
+ APrevItem.Token := etLitDate;
+ Remove(AArgument);
+ Remove(ANextItem);
+ end;
+ else raise TRtfException.Create('Invalid formula');
+ end;
+ end;
+ etComma: begin
+ //Fix for constant int's and float's
+ case ANextItem.Token of
+ etLitInt, etLitFloat, etLitDate: begin
+ case AArgument.Token of
+ etAdd:; //nothing just a (..., +Value)
+ etSub: ANextItem.Value := ANextItem.Value * - 1;
+ else raise TRtfException.Create('Invalid formula');
+ end;
+ Remove(AArgument);
+ end;
+ else raise TRtfException.Create('Invalid formula');
+ end;
+ end;
+ etAssign: begin
+ //Fix for constant int's and float's
+ case ANextItem.Token of
+ etLitInt, etLitFloat, etLitDate: begin
+ case AArgument.Token of
+ etAdd:; //nothing just a @Variable := +Value
+ etSub: ANextItem.Value := ANextItem.Value * - 1;
+ else raise TRtfException.Create('Invalid formula');
+ end;
+ Remove(AArgument);
+ end;
+ else raise TRtfException.Create('Invalid formula');
+ end;
+ end;
+ else raise TRtfException.Create('Invalid formula'); //Otherwise it wont advance
+ end;
+ if Assigned(Parser.OnEvalutate)
+ then Parser.OnEvalutate(Self);
+end;
+
+procedure TRtfArgument.EvaluateComparison(APrevItem, AArgument, ANextItem: TRtfArgument);
+begin
+ if(APrevItem.Token = etLitString)and(ANextItem.Token <> etLitString)
+ then raise TRtfException.Create('Invalid comparison');
+ if(ANextItem.Token = etLitString)and(APrevItem.Token <> etLitString)
+ then raise TRtfException.Create('Invalid comparison');
+
+ case AArgument.Token of
+ etEQ: APrevItem.Value := APrevItem.Value = ANextItem.Value;
+ etNE: APrevItem.Value := APrevItem.Value <> ANextItem.Value;
+ etGE: APrevItem.Value := APrevItem.Value >= ANextItem.Value;
+ etLE: APrevItem.Value := APrevItem.Value <= ANextItem.Value;
+ etGT: APrevItem.Value := APrevItem.Value > ANextItem.Value;
+ etLT: APrevItem.Value := APrevItem.Value < ANextItem.Value;
+ etOr: APrevItem.Value := APrevItem.Value or ANextItem.Value;
+ etAnd: APrevItem.Value := APrevItem.Value and ANextItem.Value;
+ else raise TRtfException.Create('Invalid comparison');
+ end;
+ if APrevItem.Value
+ then APrevItem.Token := etLitTrue
+ else APrevItem.Token := etLitFalse;
+
+ Remove(AArgument);
+ Remove(ANextItem);
+ if Assigned(Parser.OnEvalutate)
+ then Parser.OnEvalutate(Self);
+end;
+
+procedure TRtfArgument.EvaluateAssign(APrevItem, AArgument, ANextItem: TRtfArgument);
+var AVariable: TRtfVariable;
+begin
+ if APrevItem.Token <> etVariable
+ then raise TRtfException.Create('Invalid assignment');
+
+ AVariable := Parser.Variables.Find(APrevItem.Value);
+ if Assigned(AVariable) then begin
+ AVariable.Value := ANextItem.Value;
+ AVariable.Token := ANextItem.Token;
+ end
+ else AVariable := Parser.Variables.Add(APrevItem.Value, ANextItem.Value, ANextItem.Token);
+
+ APrevItem.Value := AVariable.Value;
+ APrevItem.Token := AVariable.Token;
+
+ Remove(AArgument);
+ Remove(ANextItem);
+ if Assigned(Parser.OnEvalutate)
+ then Parser.OnEvalutate(Self);
+end;
+
+procedure TRtfArgument.GetPictureData(ABuffer: pointer; ALength: cardinal; var Result: string);
+var ASrc: Pbyte;
+ ADst: pchar;
+ AIndex: cardinal;
+ i: integer;
+ s: string;
+begin
+ if poBinary in Parser.PictureOptions then begin
+ //Save graphic binary
+ Result := Format('%s\bin%d ',[Result, ALength]);
+ AIndex := Length(Result);
+ SetLength(Result, AIndex + ALength);
+ ADst := @Result[AIndex + 1];
+ System.Move(ABuffer^, ADst^, ALength);
+ end else begin
+ //Save graphics as hex
+ ASrc := ABuffer;
+ Result := Result + ' ';
+ AIndex := Length(Result);
+ SetLength(Result, AIndex + 2 *(ALength +(ALength div 128)));
+ ADst := @Result[AIndex + 1];
+ for i := 0 to ALength - 1 do begin
+ s := IntToHex(ASrc^, 2);
+ ADst^ := s[1];
+ Inc(ADst);
+ ADst^ := s[2];
+ Inc(ADst);
+ if(i > 0)and(i and 127 = 0) then begin
+ ADst^ := #13;
+ Inc(ADst);
+ ADst^ := #10;
+ Inc(ADst);
+ end;
+ Inc(ASrc);
+ end;
+ end;
+ Result := Result + #13#10 + '}';
+end;
+
+function TRtfArgument.GetPicture(APicture: TPicture): string;
+//Convert a picture to a string suitable for in the Rtf
+(*
+var
+ xw, yh: word;
+ Rect: TRect;
+ ARefDC: HDC;
+ ABuffer: pointer;
+ ALength: cardinal;
+ AMetafile: TMetafile;
+ ABorderWidth: integer;
+ APictureAttr: TRtfPictureAttr;
+ ppi, AColorIndex, xtw, ytw: integer;
+*)
+begin
+ Result := '';
+ (*
+ ppi := Screen.PixelsPerInch;
+
+ AMetafile := TMetaFile.Create;
+ try
+ AMetafile.Enhanced := true;
+
+ if poMetafile in Parser.PictureOptions then begin
+ AMetafile.Width := Round(APicture.Graphic.Width * ppi / 96);
+ AMetafile.Height := Round(APicture.Graphic.Height * ppi / 96);
+ end else begin
+ if(APicture.graphic is TMetafile)and not APicture.Metafile.Enhanced then begin
+ AMetafile.Height := APicture.graphic.Height;
+ AMetafile.Width := APicture.graphic.Width;
+ end else begin
+ AMetafile.Height := Round(APicture.graphic.Height * ppi / 96);
+ AMetafile.Width := Round(APicture.graphic.Width * ppi / 96);
+ end;
+ end;
+
+ Rect.Top := 0;
+ Rect.Left := 0;
+ Rect.Right := AMetafile.Width - 1;
+ Rect.Bottom := AMetafile.Height - 1;
+
+ with TMetaFileCanvas.Create(AMetafile, 0)do try
+ if ppi = 96
+ then Draw(0, 0, APicture.Graphic)
+ else StretchDraw(Rect, APicture.Graphic);
+ finally
+ Free;
+ end;
+
+ if(APicture.Graphic is TMetafile)and not APicture.Metafile.Enhanced then begin
+ xw := Round(APicture.Width * 96 / ppi);
+ yh := Round(APicture.Height * 96 / ppi);
+ end else begin
+ xw := APicture.Width;
+ yh := APicture.Height;
+ end;
+
+ APictureAttr := TRtfPictureAttr.Create(xw, yh);
+ try
+ AMetafile.MMWidth := Round(APictureAttr.Widthmm * 100);
+ AMetafile.MMHeight := Round(APictureAttr.Heigthmm * 100);
+
+ if poMetafile in Parser.PictureOptions then begin
+ xtw := Round(APictureAttr.Width * 26.4596930676);
+ ytw := Round(APictureAttr.Heigth * 26.4596930676);
+ end else begin
+ xtw := Round(5669 * APictureAttr.Widthmm / 100);
+ ytw := Round(5669 * APictureAttr.Heigthmm / 100);
+ end;
+
+ if Assigned(Parser.OnPictureAttr)
+ then Parser.OnPictureAttr(APictureAttr);
+
+ Result := Format('{\pict\picscalex%d\picscaley%d\piccropl0' +
+ '\piccropr0\piccropt0\piccropb0\picw%d\pich%d',
+ [APictureAttr.ScaleX, APictureAttr.ScaleY, xtw, ytw]);
+ if poMetafile in Parser.PictureOptions
+ then Result := Result + '\wmetafile8'
+ else Result := Result + '\emfblip';
+
+ if(APictureAttr.BorderType <> brNone)and(APictureAttr.BorderWidth > 0) then begin
+ case APictureAttr.BorderType of
+ brSingle: Result := Result + '\brdrs';
+ brDouble: Result := Result + '\brdrdb';
+ brThick: Result := Result + '\brdrth';
+ brShadow: Result := Result + '\brdrsh';
+ brDot: Result := Result + '\brdrdot';
+ brHair: Result := Result + '\brdrhair';
+ end;
+
+ ABorderWidth := APictureAttr.BorderWidth;
+ if ABorderWidth > 75
+ then ABorderWidth := 75;
+
+ AColorIndex := Parser.ColorList.UseColor(APictureAttr.BorderColor);
+ Result := Format('%s\brdrw%d\brdrcf%d',[Result, ABorderWidth, AColorIndex]);
+ end;
+ finally
+ APictureAttr.Free;
+ end;
+
+
+ if poMetafile in Parser.PictureOptions then begin
+ ARefDC := GetDC(0);
+ try
+ ALength := GetWinMetaFileBits(AMetafile.Handle, 0, nil, MM_ANISOTROPIC, ARefDC);
+ GetMem(ABuffer, ALength);
+ try
+ GetWinMetaFileBits(AMetafile.Handle, ALength, ABuffer, MM_ANISOTROPIC, ARefDC);
+ GetPictureData(ABuffer, ALength, Result);
+ finally
+ FreeMem(ABuffer);
+ end;
+ finally
+ ReleaseDC(0, ARefDc);
+ end;
+ end else begin
+ ALength := GetEnhMetaFileBits(AMetafile.Handle, 0, nil);
+ GetMem(ABuffer, ALength);
+ try
+ GetEnhMetaFileBits(AMetafile.Handle, ALength, ABuffer);
+ GetPictureData(ABuffer, ALength, Result);
+ finally
+ FreeMem(ABuffer);
+ end;
+ end;
+ finally
+ AMetafile.Free;
+ end;
+ *)
+end;
+
+procedure TRtfArgument.GetGraphicsValue(ADataset: TRtfDataset; AFieldName: string);
+(*
+var
+ APicture: TPicture;
+ ABlob: TBlobField;
+ APhoto: TJPEGImage;
+ AStream: TStringStream;
+ s: string[20];
+ AField: TField;
+*)
+begin
+(*
+ Value := varEmpty;
+ Token := etNothing;
+ if ADataset.Dataset is TDataset then begin
+ AField :=(ADataset.Dataset as TDataset).FieldByName(AFieldName);
+
+ APicture := TPicture.Create;
+ try
+ ABlob := AField as TBlobField;
+ s := Copy(ABlob.Value, 1, 20);
+ if(Pos('GIF8', s) > 0)or(Pos('JFIF', s) > 0) then begin
+ APhoto := TJPEGImage.Create;
+ try
+ AStream := TStringStream.Create(ABlob.AsString);
+ APhoto.LoadFromStream(AStream);
+ APicture.Assign(APhoto);
+ finally
+ FreeAndNil(APhoto);
+ FreeAndNil(AStream);
+ end;
+ end
+ else APicture.Assign(ABlob);
+
+ if Assigned(APicture.Graphic) then begin
+ Value := GetPicture(APicture);
+ Token := etLitString;
+ end;
+
+ finally
+ APicture.Free;
+ end;
+ end
+ else
+ raise TRtfException.Create('Graphic fields worden alleen ondersteund via de tdataset!');
+*)
+end;
+
+procedure TRtfArgument.ResolveFieldValue(ADataset: TRtfDataset; AFieldName: string);
+//Get field data from a dataset object
+var
+ AObject: TObject;
+ APropInfo: PPropInfo;
+ ATypedata: PTypeData;
+ ATable: TDataset;
+ AField: TField;
+begin
+ //Can't resolve that
+ if AFieldName = '' then
+ raise TRtfException.Create('invalid fieldname');
+
+ if ADataset.Dataset is TDataset then
+ begin
+ ATable := ADataset.Dataset as TDataset;
+ AField := ATable.FieldByName(AFieldName);
+ case AField.DataType of
+ ftMemo, ftFmtMemo, ftFixedChar, ftWideString, ftString: begin
+ Token := etLitString;
+ Value := AField.AsString;
+ end;
+ ftLargeint, ftAutoInc, ftSmallint, ftInteger, ftWord: begin
+ Token := etLitInt;
+ Value := AField.AsInteger;
+ end;
+ ftBoolean: begin
+ Value := AField.AsBoolean;
+ if Value then
+ Token := etLitTrue
+ else
+ Token := etLitFalse;
+ end;
+ ftFloat, ftCurrency, ftBCD: begin
+ Token := etLitFloat;
+ Value := AField.AsFloat;
+ end;
+ ftDate, ftTime, ftDateTime, ftTimeStamp: begin
+ Token := etLitDate;
+ Value := AField.AsDateTime;
+ end;
+ ftGraphic: begin
+ GetGraphicsValue(ADataset, AFieldName);
+ end;
+ else
+ raise TRtfException.CreateFmt('Unable to convert field "%s" value',[AFieldName]);
+ end;
+ end
+ else
+ begin
+ AObject := ADataset.Dataset;
+ if AObject is TtiObjectList then
+ begin
+ //Get the right record from the array
+ if ADataset.TableIndex <(AObject as TtiObjectList).Count then
+ AObject :=(AObject as TtiObjectList)[ADataset.TableIndex]
+ else
+ begin //Trying beyond eof (or empty dataset) big problem; nah?
+ Token := etNothing;
+ Value := varEmpty;
+ exit;
+ end;
+ end;
+ APropInfo := GetPropInfo(AObject, AFieldName);
+ if not Assigned(APropInfo) then
+ raise TRtfException.CreateFmt('Field "%s" does not exist',[AFieldName]);
+ if not Assigned(APropInfo^.GetProc) then
+ raise TRtfException.CreateFmt('Cannot access field "%s"',[AFieldName]);
+ {$IFDEF FPC}
+ ATypeData := GetTypeData(APropInfo^.PropType);
+ {$ELSE}
+ ATypeData := GetTypeData(APropInfo^.PropType^);
+ {$ENDIF}
+
+ case APropInfo^.PropType^.Kind of
+ tkChar, tkString, tkLString, tkWString{$IFDEF FPC},tkAString{$ENDIF}: begin
+ Token := etLitString;
+ Value := GetStrProp(AObject, APropInfo);
+ end;
+ tkInt64: begin
+ Token := etLitInt;
+ Value := GetInt64Prop(AObject, APropInfo);
+ end;
+ tkSet, tkInteger: begin
+ Token := etLitInt;
+ Value := GetOrdProp(AObject, APropInfo);
+ end;
+ tkEnumeration: begin
+ {$IFDEF FPC}
+ if ATypeData^.BaseType = TypeInfo(boolean) then
+ {$ELSE}
+ if ATypeData^.BaseType^ = TypeInfo(boolean) then
+ {$ENDIF}
+ begin
+ Value := GetOrdProp(AObject, APropInfo) = 1;
+ if Value then
+ Token := etLitTrue
+ else
+ Token := etLitFalse;
+ end
+ else
+ begin
+ Token := etLitInt;
+ Value := GetOrdProp(AObject, APropInfo);
+ end;
+ end;
+ tkFloat: begin
+ if SameText(APropInfo^.PropType^.Name, 'TDate')
+ or SameText(APropInfo^.PropType^.Name, 'TTime')
+ or SameText(APropInfo^.PropType^.Name, 'TDateTime') then
+ Token := etLitDate
+ else
+ Token := etLitFloat;
+ Value := GetFloatProp(AObject, APropInfo);
+ end;
+ else
+ raise TRtfException.CreateFmt('Unable to convert field "%s" value',[AFieldName]);
+ end; { case }
+ end; { if/else }
+end;
+
+procedure TRtfArgument.ResolveVariable;
+var AVariable: TRtfVariable;
+ AText, AFieldName: string;
+ ADataset: TRtfDataset;
+ AIndex: integer;
+begin
+ AText := Value;
+ AIndex := Pos('.', AText);
+ if AIndex > 0 then begin
+ //Its a dataset reference @Table.Fieldname
+ AFieldName := Copy(AText, AIndex + 1, Maxint);
+ AText := Copy(AText, 1, AIndex - 1);
+
+ AVariable := Parser.Variables.Find(AText);
+ if not Assigned(AVariable)
+ then raise TRtfException.Create('variable does not exist');
+ Token := AVariable.Token;
+ Value := AVariable.Value;
+ if Token <> etDataset
+ then raise TRtfException.Create('variable is not a dataset');
+
+ ADataset := TRtfDataset(integer(Value));
+ ADataset := ADataset.ResolveNestedFields(ADataset, AFieldName, AFieldName);
+ if AFieldName = '' then begin
+ //Its a (nested) dataset
+ Token := etDataset;
+ Value := integer(ADataset);
+ end
+ else ResolveFieldValue(ADataset, AFieldName);
+ end else begin
+ AVariable := Parser.Variables.Find(AText);
+ if not Assigned(AVariable)
+ then raise TRtfException.Create('variable does not exist');
+ Token := AVariable.Token;
+ Value := AVariable.Value;
+ end;
+end;
+
+procedure TRtfArgument.ResolveFieldName;
+//Resolve dataset names or fieldnames (seperated with ".")
+var ADataset: TRtfDataset;
+ AFieldName: string;
+begin
+ //Otherwise it should be a table reference or fieldname
+ ADataset := Parser.Datasets.Find(Value, AFieldName);
+ if not Assigned(ADataset) //There should be at least a table reference.
+ then raise TRtfException.CreateFmt('Dataset "%s" not found',[Value]);
+ if AFieldName <> ''
+ then ResolveFieldValue(ADataset, AFieldName)
+ else begin
+ //Its a dataset or objectlist reference
+ Token := etDataset;
+ Value := integer(ADataset);
+ end;
+end;
+
+procedure TRtfArgument.Walk(ATokenset: TRtfTokenSet; AExecproc: TRtfArgumentEvent);
+//Not really neat (what can you expect in 1 day)
+var i: integer;
+ AText: string;
+ AResolve: boolean;
+ AParent, APrevItem, AArgument, ANextItem: TRtfArgument;
+begin
+ if Count > 0 then begin
+ i := 0;
+ while i < Count do begin
+ AArgument := Items[i];
+
+ if AArgument.Token = etVariable then begin
+ if(i >= Count - 1)or(Items[i + 1].Token <> etAssign)
+ then AArgument.ResolveVariable;
+ end else if AArgument.Token = etFieldName then begin
+ //An exception is the DbPicture(Table.Field). It shoud not evaluate
+ //since the DbPicture function should be responsible for that.
+ AResolve := true;
+ AParent := AArgument.Parent;
+ if Assigned(AParent) then begin
+ AText := AParent.Value;
+ if SameText(AText, 'DbPicture')
+ then AResolve := false;
+ end;
+ if AResolve
+ then AArgument.ResolveFieldName;
+ end;
+
+ if AArgument.Token = etNot then begin
+ if i < Count - 1
+ then ANextItem := Items[i + 1]
+ else raise TRtfException.Create('invalid formula');
+ if ANextItem.Token = etLitFalse
+ then ANextItem.Value := true
+ else if ANextItem.Token = etLitTrue
+ then ANextItem.Value := false
+ else raise TRtfException.Create('invalid formula');
+ Remove(AArgument);
+ end else if AArgument.Token in ATokenSet then begin
+ if i > 0
+ then APrevItem := Items[i - 1]
+ else raise TRtfException.Create('invalid formula');
+ if i < Count - 1
+ then ANextItem := Items[i + 1]
+ else raise TRtfException.Create('invalid formula');
+ AExecproc(APrevItem, AArgument, ANextItem);
+ end
+ else Inc(i);
+ end;
+
+ if(Count = 1)and(Token = etParenthesis) then begin
+ //Advance the answer from between parenthesis to parent.
+ AArgument := Items[0];
+ Value := AArgument.Value;
+ Token := AArgument.Token;
+ Remove(AArgument);
+ if Assigned(Parser.OnEvalutate)
+ then Parser.OnEvalutate(Self);
+ end;
+ end;
+end;
+
+procedure TRtfArgument.EvaluateExpression;
+//Not really neat (what can you expect in 1 day)
+//Evaluate the entered expression via ParseExpression()
+var AFunction: TRtfFunction;
+ AArgument: TRtfArgument;
+ i: integer;
+begin
+ if Count > 0 then begin
+ //First the binary operators
+ Walk([etMul, etDiv], {$IFDEF FPC}@{$ENDIF}EvaluateUnaryBinary);
+ //Secondly the unary operators
+ Walk([etAdd, etSub], {$IFDEF FPC}@{$ENDIF}EvaluateUnaryBinary);
+ //And finally the simple comparisons
+ Walk([etEQ, etNE, etGE, etLE, etGT, etLT], {$IFDEF FPC}@{$ENDIF}EvaluateComparison);
+ //And finally the more "complicated" comparisons
+ Walk([etAnd, etOr], {$IFDEF FPC}@{$ENDIF}EvaluateComparison);
+ end;
+
+
+ if Token in[etFunction, etProcedure] then begin
+ AFunction := Parser.Functions.Find(Value);
+ if not Assigned(AFunction)
+ then raise TRtfException.Create('Cannot resolve function');
+
+ if not Assigned(AFunction.OnExecute)
+ then raise TRtfException.Create('Cannot resolve function');
+
+ //Remove now redundant comma's
+ for i := Count - 1 downto 0 do begin
+ AArgument := Items[i];
+ if AArgument.Token = etComma
+ then Remove(AArgument)
+ else if VarIsEmpty(AArgument.Value)
+ then raise TRtfException.Create('Function needs valid parameters');
+ end;
+
+ if Count < AFunction.Min
+ then raise TRtfException.Create('expected more parameters');
+ if Count > AFunction.Max
+ then raise TRtfException.Create('to many parameters');
+
+ Value := varEmpty;
+ Token := etNothing;
+ if Assigned(Parser.OnEvalutate)
+ then Parser.OnEvalutate(Self);
+ AFunction.OnExecute(Self);
+ Clear; //Clear parameters
+ if Assigned(Parser.OnEvalutate)
+ then Parser.OnEvalutate(Self);
+ end;
+
+ //And not to forget any optional assignments
+ if Count > 0
+ then Walk([etAssign], {$IFDEF FPC}@{$ENDIF}EvaluateAssign);
+end;
+
+procedure TRtfArgument.Evaluate;
+//Not really neat (what can you expect in 1 day)
+//Evaluate the expression (not very efficient, but what the hack)
+var i: integer;
+ AText: string;
+ AArgument: TRtfArgument;
+begin
+ for i := 0 to Count - 1 do begin
+ AArgument := Items[i];
+ AArgument.Evaluate;
+ end;
+ EvaluateExpression;
+
+ if(Parent = nil)and(Count > 1)
+ then raise TRtfException.Create('invalid formula');
+
+ if Count = 1 then begin
+ //Advance the answer from between parenthesis to parent.
+ AArgument := Items[0];
+ Value := AArgument.Value;
+ Token := AArgument.Token;
+ Param := AArgument.Param;
+ Clear;
+ if Assigned(Parser.OnEvalutate)
+ then Parser.OnEvalutate(Self);
+ end;
+
+ if Token = etLitString then begin
+ //Fix: DbExpres appends a #0 character to memo fields
+ AText := Value;
+ if(Length(AText) > 0)and(AText[Length(AText)] = #0)
+ then Value := Copy(AText, 1, Length(AText) - 1);
+ end;
+end;
+
+
+{ TRtfColor }
+
+function TRtfColor.GetAsString: string;
+begin
+ Result := Format('\red%d\green%d\blue%d;',[Red, Green, Blue]);
+end;
+
+{ TRtfColorList }
+
+function TRtfColorList.GetItem(Index: integer): TRtfColor;
+begin
+ Result := TRtfColor(inherited Items[Index]);
+end;
+
+procedure TRtfColorList.Clear;
+begin
+ inherited;
+ Add(0, 0, 0); //Dummy color..
+end;
+
+function TRtfColorList.Add(ARed, AGreen, ABlue: integer): integer;
+var AColor: TRtfColor;
+begin
+ AColor := TRtfColor.Create;
+ AColor.Red := ARed;
+ AColor.Green := AGreen;
+ AColor.Blue := ABlue;
+ Result := inherited Add(AColor);
+end;
+
+function TRtfColorList.Find(ARed, AGreen, ABlue: integer): integer;
+var
+ i: integer;
+ AColor: TRtfColor;
+begin
+ //0 is a dummy color
+ for i := 1 to Count - 1 do
+ begin
+ AColor := Items[i];
+ if(AColor.Red = ARed)and(AColor.Green = AGreen)and(AColor.Blue = ABlue) then
+ begin
+ Result := i;
+ exit;
+ end;
+ end;
+ Result := - 1;
+end;
+
+function TRtfColorList.GetAsString: string;
+var
+ i: integer;
+ AColor: TRtfColor;
+begin
+ Result := '';
+ //0 is a dummy color
+ for i := 1 to Count - 1 do
+ begin
+ AColor := Items[i];
+ Result := Result + AColor.AsString;
+ end;
+end;
+
+function TRtfColorList.UseColor(ARed, AGreen, ABlue: integer): integer;
+begin
+ Result := Find(ARed, AGreen, ABlue);
+ if Result < 0
+ then Result := Add(ARed, AGreen, ABlue);
+end;
+
+function TRtfColorList.UseColor(AColor: TColor): integer;
+var ARed, AGreen, ABlue: integer;
+begin
+ ARed := AColor and 255;
+ AColor := AColor shr 8;
+ AGreen := AColor and 255;
+ AColor := AColor shr 8;
+ ABlue := AColor and 255;
+ Result := UseColor(ARed, AGreen, ABlue);
+end;
+
+
+{ TtiRtfParser }
+
+constructor TtiRtfParser.Create;
+begin
+ inherited Create;
+ FBoolTrue := 'Ja';
+ FBoolFalse := 'Nee';
+ FErrorForeColor := clRed;
+ FErrorBackColor := clYellow;
+ FPictureOptions :=[poMetafile, poBinary];
+ FHlpItems := TRtfItem.Create;
+ TmpItems := TObjectlist.Create;
+ FDatasets := TRtfDataset.Create;
+ FRtfItems := TRtfItemList.Create;
+ FRawItems := TRtfItemList.Create;
+ FColorList := TRtfColorList.Create;
+ FVariables := TRtfVariableList.Create;
+ FFunctions := TRtfFunctionList.Create;
+ AddFunctions;
+end;
+
+destructor TtiRtfParser.Destroy;
+begin
+ FDatasets.Free;
+ FRtfItems.Free;
+ TmpItems.Free;
+ FHlpItems.Free;
+ FVariables.Free;
+ FFunctions.Free;
+ FRawItems.Free;
+ FColorList.Free;
+ inherited;
+end;
+
+procedure TtiRtfParser.Clear;
+begin
+ TmpItems.Clear;
+ RawItems.Clear;
+ RtfItems.Clear;
+ HlpItems.Clear;
+ ColorList.Clear;
+end;
+
+procedure TtiRtfParser.SaveToFile(AFileName: string);
+var AStream: TMemoryStream;
+begin
+ AStream := TMemoryStream.Create;
+ try
+ RtfItems.SaveToStream(AStream, ColorList.AsString);
+ AStream.SaveToFile(AFileName);
+ finally
+ AStream.Free;
+ end;
+end;
+
+function TtiRtfParser.SaveToString: string;
+var AStream: TMemoryStream;
+begin
+ Result := '';
+ AStream := TMemoryStream.Create;
+ try
+ RtfItems.SaveToStream(AStream, ColorList.AsString);
+ SetLength(Result, AStream.Size);
+ if AStream.Size > 0 //Humble admitted its a bit dirty
+ then Move(AStream.Memory^, Result[1], AStream.Size);
+ finally
+ AStream.Free;
+ end;
+end;
+
+procedure TtiRtfParser.SaveToStream(AStream: TMemoryStream);
+begin
+ RtfItems.SaveToStream(AStream, ColorList.AsString);
+end;
+
+function TtiRtfParser.AddVariable(AName: string; AValue: variant; AToken: TRtfToken): TRtfVariable;
+begin
+ Result := Variables.Add(AName, AValue, AToken);
+end;
+
+function TtiRtfParser.AddDataset(ATable: TObject; AName: string; AFreeDataset: boolean = false): TRtfDataset;
+begin
+ Result := Datasets.Add(ATable, AName, AFreeDataset);
+end;
+
+function TtiRtfParser.AddFunction(AName: string; ATokenType: TRtfToken; AMin, AMax: smallint; AOnexecute: TRtfFunctionExecute): TRtfFunction;
+begin
+ Result := Functions.Add(ATokenType, AName, AMin, AMax, AOnexecute);
+end;
+
+function TtiRtfParser.AddToRtfItems(AItem: TRtfItem): TRtfItem;
+begin
+ Result := TRtfItem.Create;
+ Result.Assign(AItem);
+ RtfItems.Add(Result);
+end;
+
+procedure TtiRtfParser.LoadFromFile(AFilename: string);
+//Tokenize the raw rtf and put it into rawitems
+var
+ AStream: TMemoryStream;
+begin
+ Clear;
+ AStream := TMemoryStream.Create;
+ try
+ AStream.LoadFromFile(AFileName);
+ LoadFromBuffer(AStream.Memory, AStream.Size);
+ finally
+ FreeAndNil(AStream);
+ end;
+end;
+
+procedure TtiRtfParser.LoadFromStream(AStream: TMemoryStream);
+//Tokenize the raw rtf and put it into rawitems
+begin
+ LoadFromBuffer(AStream.Memory, AStream.Size);
+end;
+
+procedure TtiRtfParser.LoadFromString(AString: string);
+//Tokenize the raw rtf and put it into rawitems
+begin
+ LoadFromBuffer(pchar(AString), Length(AString));
+end;
+
+procedure TtiRtfParser.LoadFromBuffer(ABuffer: pchar; ASize: integer);
+//Tokenize the raw rtf and put it into rawitems
+var AColorTable: TRtfItem;
+ AColors, AToken: string;
+ ANumber, ARed, AGreen, ABlue: integer;
+ p: pchar;
+begin
+ Clear;
+ with TRawRtfParser.Create do try
+ Execute(FRawItems, ABuffer, ASize);
+ AColorTable := ColorTable;
+ finally
+ Free;
+ end;
+
+ if not Assigned(AColorTable)
+ then raise TRtfException.Create('no colortbl found');
+
+ //Parse the color table (tiny parser)
+ ARed := 0;
+ ABlue := 0;
+ AGreen := 0;
+ AColors := Copy(AColorTable.RtfTextBuf, 11, Maxint);
+ p := pchar(AColors);
+ while p <> #0 do begin
+ case p^ of
+ '\': begin
+ inc(p);
+ AToken := '';
+ ANumber := 0;
+ while(p^ in['A'..'Z', 'a'..'z'])do begin
+ AToken := AToken + p^;
+ inc(p);
+ end;
+ while(p^ in['0'..'9'])do begin
+ ANumber :=(ANumber * 10) +(ord(p^) - ord('0'));
+ inc(p);
+ end;
+ ANumber := ANumber and 255;
+ if SameText(AToken, 'red')
+ then ARed := ANumber
+ else if SameText(AToken, 'blue')
+ then ABlue := ANumber
+ else if SameText(AToken, 'green')
+ then AGreen := ANumber;
+ end;
+ ';': begin
+ inc(p);
+ ColorList.UseColor(ARed, AGreen, ABlue);
+ ARed := 0;
+ ABlue := 0;
+ AGreen := 0;
+ end;
+ #13, #10: inc(p);
+ '}': break;
+ else raise TRtfException.Create('Invalid character in colortbl');
+ end;
+ end;
+
+ (*
+ {\colortbl;\red0\green0\blue;\red255\green0\blue;\red255\green255\blue;\red0\green255\blue;\red255\green0\blue;\red0\green0\blue;\red0\green255\blue;\red255\green255\blue;\red128\green0\blue;\red128\green128\blue;\red0\green128\blue;\red128\green0\blue;\red0\green0\blue;\red0\green128\blue;\red128\green128\blue;\red192\green192\blue;}
+ *)
+end;
+
+procedure TtiRtfParser.Execute;
+//Rtf has been already been loaded
+begin
+ PreParse; //Create a tree for easy parsing of if-then-else and scan-endscan etc.
+ Parse(HlpItems); //Parse the tree items in the structure..
+end;
+
+procedure TtiRtfParser.PreParse;
+//Preparse the items from Items to Structure
+//This will make a tree from (sub)expressions and code.
+//Specially for the if/else/endif and scan/scanend
+var AIndex, AForeColor, ABackColor: integer;
+ AItem, AStart, ABranche: TRtfItem;
+ AArguments: TRtfArgument;
+ ARemoveParagraph: boolean;
+ AFirstArgument: string;
+ AFirstToken: TRtfToken;
+ AText: string;
+begin
+ AItem := RawItems.Head;
+ AArguments := TRtfArgument.Create(Self);
+ try
+ //Round 1: create expression nodes
+ while Assigned(AItem)do begin
+ if AItem.RtfClass = RtfParsebegin then begin
+
+ //Items starts with a RtfParseBegin
+ AText := AItem.RtfTextBuf; //Initial expression
+ AStart := HlpItems[HlpItems.Add(AItem)];
+ AStart.RtfClass := RtfExpression;
+ AStart.RtfMajor := RtfNormalExpression;
+ AStart.RtfTextBuf := '';
+ AItem := AItem.Next;
+ while Assigned(AItem)do begin
+ case AItem.RtfClass of
+ RtfParseEnd: begin //End of expression
+ AText := AText + AItem.RtfTextBuf;
+ AItem := AItem.Next; //Skip's ParseEnd
+ break;
+ end;
+ RtfParseBegin: begin //WTF: Start of expression, this should not happen. Inform user
+ raise TRtfException.Create('Error in preparse? at ' + AText);
+ end;
+ RtfText: AText := AText + AItem.RtfTextBuf;
+ RtfControl: begin
+ case AItem.RtfMajor of
+ RtfSpecialChar: begin //Add some special characters
+ case AItem.RtfMinor of
+ RtfPar, RtfParDef:; //Ignore these
+ RtflQuote, RtfrQuote: AText := AText + Chr(39);
+ RtflDblQuote, RtfrDblQuote: AText := AText + '"';
+ else AText := AText + AItem.RtfTextBuf; //Hope this is Ok?
+ end;
+ end;
+ else HlpItems.Add(AItem);
+ end;
+ end;
+ else HlpItems.Add(AItem);
+ end;
+ AItem := AItem.Next;
+ end;
+
+ AStart.RtfTextBuf := StringReplace(AText, #13#10, '',[rfReplaceAll]);
+ AArguments.Clear;
+ ARemoveParagraph := true;
+ try
+ AArguments.ParseExpression(AText);
+ except
+ on e: Exception do begin
+ //Ignore at this moment, it will be triggered again in the Parse()
+ end;
+ end;
+ if AArguments.Count > 0 then begin
+ AFirstToken := AArguments[0].Token;
+ AFirstArgument := AArguments[0].Value;
+ if SameText(AFirstArgument, 'if')
+ then AStart.RtfMajor := RtfIfExpression
+ else if SameText(AFirstArgument, 'else')
+ then AStart.RtfMajor := RtfElseExpression
+ else if SameText(AFirstArgument, 'endif')
+ then AStart.RtfMajor := RtfEndifExpression
+ else if SameText(AFirstArgument, 'scan')
+ then AStart.RtfMajor := RtfScan
+ else if SameText(AFirstArgument, 'endscan')
+ then AStart.RtfMajor := RtfScanEnd
+ else if SameText(AFirstArgument, 'scanentry')
+ then AStart.RtfMajor := RtfScanEntry
+ else if SameText(AFirstArgument, 'scanfooter')
+ then AStart.RtfMajor := RtfScanFooter;
+ ARemoveParagraph := AFirstToken in[etVariable, etProcedure, etNothing];
+ if(AFirstToken = etVariable)and(AArguments.Count = 1)
+ then ARemoveParagraph := false; //One exception: variable reference
+ end;
+
+ if ARemoveParagraph
+ then AItem := SkipParagraph(AItem);
+ end else begin
+ HlpItems.Add(AItem);
+ AItem := AItem.Next;
+ end;
+ end;
+
+ finally
+ AArguments.Free;
+ end;
+
+ //Round 2: create if then else expression sub-nodes
+ AIndex := 0;
+ ABranche := nil;
+ while AIndex < HlpItems.Count do begin
+ AItem := HlpItems[AIndex];
+ try
+
+ if AItem.CheckItem(RtfExpression, RtfIfExpression) then begin
+ if Assigned(ABranche) then begin
+ HlpItems.Extract(AItem);
+ ABranche.Add(AItem);
+ end
+ else Inc(AIndex);
+
+ ABranche := TRtfItem.Create;
+ ABranche.RtfClass := RtfBranche;
+ ABranche.RtfMajor := RtfThenExpression;
+ TmpItems.Add(ABranche); //Otherwise memory leak
+ AItem.Add(ABranche);
+ end else if AItem.CheckItem(RtfExpression, RtfElseExpression) then begin
+ if not Assigned(ABranche)
+ then raise TRtfException.Create('unexpected else');
+
+ HlpItems.Extract(AItem); //Remove else item
+ AItem := ABranche.Parent; //Points to "if" statement
+ if AItem.RtfClass = RtfBranche
+ then AItem := AItem.Parent; //Points to "if" statement
+ if not Assigned(AItem)
+ then raise TRtfException.Create('unexpected else');
+ if not AItem.CheckItem(RtfExpression, RtfIfExpression)
+ then raise TRtfException.Create('unexpected scanentry');
+
+ ABranche := TRtfItem.Create;
+ ABranche.RtfClass := RtfBranche;
+ ABranche.RtfMajor := RtfElseExpression;
+ TmpItems.Add(ABranche); //Otherwise memory leak
+ AItem.Add(ABranche);
+ end else if AItem.CheckItem(RtfExpression, RtfEndifExpression) then begin
+ if not Assigned(ABranche)
+ then raise TRtfException.Create('unexpected endif');
+
+ HlpItems.Extract(AItem); //Remove item
+ ABranche := ABranche.Parent;
+ ABranche := ABranche.Parent;
+ if ABranche = HlpItems
+ then ABranche := nil;
+ end else if AItem.CheckItem(RtfExpression, RtfScan) then begin
+
+ if Assigned(ABranche) then begin
+ HlpItems.Extract(AItem);
+ ABranche.Add(AItem);
+ end
+ else Inc(AIndex);
+
+ ABranche := TRtfItem.Create;
+ ABranche.RtfClass := RtfBranche;
+ ABranche.RtfMajor := RtfScan;
+ TmpItems.Add(ABranche); //Otherwise memory leak
+ AItem.Add(ABranche);
+ end else if AItem.CheckItem(RtfExpression, RtfScanEntry) then begin
+ if not Assigned(ABranche)
+ then raise TRtfException.Create('unexpected scanentry');
+
+ HlpItems.Extract(AItem); //Remove else item
+ AItem := ABranche.Parent; //Points to "scan" statement
+ if AItem.RtfClass = RtfBranche
+ then AItem := AItem.Parent; //Points to "scan" statement
+ if not Assigned(AItem)
+ then raise TRtfException.Create('unexpected scanentry');
+ if not AItem.CheckItem(RtfExpression, RtfScan)
+ then raise TRtfException.Create('unexpected scanentry');
+
+ ABranche := TRtfItem.Create;
+ ABranche.RtfClass := RtfBranche;
+ ABranche.RtfMajor := RtfScanEntry;
+ TmpItems.Add(ABranche); //Otherwise memory leak
+ AItem.Add(ABranche);
+ end else if AItem.CheckItem(RtfExpression, RtfScanFooter) then begin
+ if not Assigned(ABranche)
+ then raise TRtfException.Create('unexpected scanfooter');
+
+ HlpItems.Extract(AItem); //Remove item
+ AItem := ABranche.Parent; //Points to "scan" statement
+ if AItem.RtfClass = RtfBranche
+ then AItem := AItem.Parent; //Points to "scan" statement
+ if not Assigned(AItem)
+ then raise TRtfException.Create('unexpected scanfooter');
+ if not AItem.CheckItem(RtfExpression, RtfScan)
+ then raise TRtfException.Create('unexpected scanfooter');
+
+ ABranche := TRtfItem.Create;
+ ABranche.RtfClass := RtfBranche;
+ ABranche.RtfMajor := RtfScanFooter;
+ TmpItems.Add(ABranche); //Otherwise memory leak
+ AItem.Add(ABranche);
+ end else if AItem.CheckItem(RtfExpression, RtfScanEnd) then begin
+ if not Assigned(ABranche)
+ then raise TRtfException.Create('unexpected scanend');
+
+ HlpItems.Extract(AItem); //Remove item
+ ABranche := ABranche.Parent;
+ ABranche := ABranche.Parent;
+ if ABranche = HlpItems
+ then ABranche := nil;
+ end else begin
+ if Assigned(ABranche) then begin
+ HlpItems.Extract(AItem);
+ ABranche.Add(AItem);
+ end
+ else Inc(AIndex);
+ end;
+ except
+ on e: Exception do begin
+ fpgApplication.HandleException(e);
+{
+ if Assigned(AItem)
+ then AItem.RtfTextBuf := AItem.RtfTextBuf + ' ' + E.Message;
+}
+ end;
+ end;
+ end;
+
+ if Assigned(ABranche) then begin
+ if Assigned(AItem) then begin
+ AForeColor := ColorList.UseColor(ErrorForeColor);
+ ABackColor := ColorList.UseColor(ErrorBackColor);
+ AItem.FRtfTextBuf := Format('{\b\ul\highlight%d\cf%d <<<<endif or endscan missing}%s',[ABackColor, AForeColor, AItem.RtfTextBuf]);
+ end;
+ end;
+end;
+
+function TtiRtfParser.SkipParagraph(AItem: TRtfItem): TRtfItem;
+//Remove paragraph breaks if it was just a procedure (or a VAR/SET etc.)
+//This can be multiple breaks (CrLf and /Par controls) but
+//do not remove more than a single item from each of them
+var AEnter, APar, AParDef: boolean;
+begin
+ APar := false;
+ AEnter := false;
+ AParDef := false;
+ while Assigned(AItem) do
+ begin
+ case AItem.RtfClass of
+ RtfText: begin
+ if not AEnter and(Pos(#13#10, AItem.RtfTextBuf) > 0) then
+ begin
+ //Crap, it can contain multiple #13#10's
+ AItem.RtfTextBuf := StringReplace(AItem.RtfTextBuf, #13#10, '',[rfReplaceAll]);
+ AItem := AItem.Next;
+ AEnter := true;
+ continue;
+ end
+ else
+ break;
+ end;
+ RtfControl: begin
+ case AItem.RtfMajor of
+ RtfSpecialChar: begin
+ case AItem.RtfMinor of
+ RtfPar: begin
+ if not APar then
+ begin
+ AItem := AItem.Next;
+ APar := true;
+ continue;
+ end
+ else
+ break;
+ end;
+ RtfParDef: begin
+ if not AParDef then
+ begin
+ AItem := AItem.Next;
+ AParDef := true;
+ continue;
+ end
+ else
+ break;
+ end;
+ end;
+ end;
+ end;
+ end;
+ end;
+ break;
+ end;
+ Result := AItem;
+end;
+
+procedure TtiRtfParser.Parse(AItems: TRtfItem);
+//Forward all stuff to the output list
+var
+ i: integer;
+ AItem: TRtfItem;
+begin
+ for i := 0 to AItems.Count - 1 do
+ begin
+ AItem := AItems[i];
+ if AItem.RtfClass = RtfExpression then
+ ParseExpression(AItem)
+ else
+ AddToRtfItems(AItem);
+ end;
+end;
+
+procedure TtiRtfParser.ParseExpression(AItem: TRtfItem);
+var
+ i, ABackColor, AForeColor: integer;
+ ARemove: boolean;
+ ADataset: TRtfDataset;
+ AScanNoEof: boolean;
+ AExpression: string;
+ AResultValue: variant;
+ AResultParam: integer;
+ AResultToken: TRtfToken;
+ AArguments: TRtfArgument;
+ AAnswer, ATemp, AHeader, ARecord, AFooter: TRtfItem;
+begin
+ AExpression := AItem.RtfTextBuf;
+ AAnswer := AddToRtfItems(AItem);
+ AAnswer.RtfTextBuf := '';
+
+ try
+ ARemove := true;
+ AArguments := TRtfArgument.Create(Self);
+ try
+ AArguments.ParseExpression(AExpression);
+ if AArguments.Count > 0 then
+ begin
+ //procedures and variables have no returning value and etNothing, well
+ ARemove := AArguments[0].Token in[etVariable, etProcedure, etNothing];
+ if (AArguments[0].Token = etVariable) and (AArguments.Count = 1) then
+ ARemove := false; //But show a single variable
+ end;
+ if Assigned(OnEvalutate) then //debug
+ OnEvalutate(AArguments);
+ AArguments.Evaluate;
+ AResultToken := AArguments.Token;
+ AResultValue := AArguments.Value;
+ AResultParam := AArguments.Param;
+ if Assigned(OnEvalutate) then //debug
+ OnEvalutate(AArguments);
+
+ case AItem.RtfMajor of
+ RtfNormalExpression: begin
+ if not ARemove then begin
+ //Expand booleans and date to text values (date because Variant
+ //have no typing for it. Place the text into the output rtf
+ if AResultToken = etLitTrue then
+ AAnswer.RtfTextBuf := BoolTrue
+ else if AResultToken = etLitFalse then
+ AAnswer.RtfTextBuf := BoolFalse
+ else if AResultToken = etLitDate then
+ begin
+ if Frac(AResultValue) = 0 then
+ AAnswer.RtfTextBuf := DateToStr(AResultValue)
+ else if Int(AResultValue) = 0 then
+ AAnswer.RtfTextBuf := TimeToStr(AResultValue)
+ else
+ AAnswer.RtfTextBuf := DateTimeToStr(AResultValue);
+ end
+ else
+ AAnswer.RtfTextBuf := VarToStr(AResultValue);
+ end;
+ end;
+
+ RtfIfExpression:
+ begin
+ if AResultToken = etLitTrue then
+ Parse(AItem[0])
+ else if(AResultToken = etLitFalse)and(AItem.Count > 1) then
+ Parse(AItem[1]);
+ end;
+
+ RtfScan:
+ begin
+ //Scan(Dataset). Find out what items is header, record and footer
+ ARecord := nil;
+ AHeader := nil;
+ AFooter := nil;
+ ADataset := TRtfDataset(integer(AResultValue)); //Dirty!
+
+ for i := 0 to AItem.Count - 1 do begin
+ ATemp := AItem[i];
+ case ATemp.RtfMajor of
+ RtfScan: AHeader := ATemp;
+ RtfScanEntry: ARecord := ATemp;
+ RtfScanFooter: AFooter := ATemp;
+ end;
+ end;
+
+ if AHeader = ARecord
+ then AHeader := nil;
+ if ARecord = nil then begin
+ ARecord := AHeader;
+ AHeader := nil;
+ end;
+
+ AScanNoEof := AResultParam = 1;
+
+ //And evaluate the Scan(dataset)
+ ADataset.Open;
+ if Assigned(AHeader)
+ then Parse(AHeader);
+ ADataset.First;
+
+ if AScanNoEof and ADataset.Eof
+ then exit; //Also no footer..
+
+ while not ADataset.Eof do begin
+ if Assigned(ARecord)
+ then Parse(ARecord);
+ ADataset.Next;
+ end;
+ if Assigned(AFooter)
+ then Parse(AFooter);
+ end;
+ end;
+ finally
+ AArguments.Free;
+ end;
+
+ except
+ on e: Exception do begin
+ AForeColor := ColorList.UseColor(ErrorForeColor);
+ ABackColor := ColorList.UseColor(ErrorBackColor);
+ AAnswer.FRtfTextBuf := Format('{\b\ul\highlight%d\cf%d %s %s}',[ABackColor, AForeColor, AExpression, E.Message]);
+ end;
+ end;
+end;
+
+procedure TtiRtfParser.AddFunctions;
+begin
+ //Extra tokens not tokenized by RawParser
+ FFunctions.Add(etOr, 'Or', 0, 0, nil);
+ FFunctions.Add(etNot, 'Not', 0, 0, nil);
+ FFunctions.Add(etAnd, 'And', 0, 0, nil);
+ FFunctions.Add(etLitTrue, 'True', 0, 0, nil);
+ FFunctions.Add(etLitFalse, 'False', 0, 0, nil);
+
+ //Date time functions/conversions
+ FFunctions.Add(etFunction, 'Year', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfYear);
+ FFunctions.Add(etFunction, 'Month', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfMonth);
+ FFunctions.Add(etFunction, 'Day', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfDay);
+ FFunctions.Add(etFunction, 'SYear', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfSYear);
+ FFunctions.Add(etFunction, 'SMonth', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfSMonth);
+ FFunctions.Add(etFunction, 'SDay', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfSDay);
+ FFunctions.Add(etFunction, 'Dtos', 1, 2, {$IFDEF FPC}@{$ENDIF}UdfDtos);
+ FFunctions.Add(etFunction, 'Stod', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfStod);
+ FFunctions.Add(etFunction, 'DateToStr', 1, 2, {$IFDEF FPC}@{$ENDIF}UdfDateToStr);
+ FFunctions.Add(etFunction, 'TimeToStr', 1, 2, {$IFDEF FPC}@{$ENDIF}UdfTimeToStr);
+ FFunctions.Add(etFunction, 'DateTimeToStr', 1, 2, {$IFDEF FPC}@{$ENDIF}UdfDateTimeToStr);
+ FFunctions.Add(etFunction, 'StrToDate', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfStrToDate);
+ FFunctions.Add(etFunction, 'StrToTime', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfStrToTime);
+ FFunctions.Add(etFunction, 'StrToDateTime', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfStrToDateTime);
+ FFunctions.Add(etFunction, 'ShortMonthName', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfShortMonthName);
+ FFunctions.Add(etFunction, 'ShortDayName', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfShortDayName);
+ FFunctions.Add(etFunction, 'LongMonthName', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfLongMonthName);
+ FFunctions.Add(etFunction, 'LongDayName', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfLongDayName);
+
+ //String, int, float functions/conversions
+ FFunctions.Add(etFunction, 'Int', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfInt);
+ FFunctions.Add(etFunction, 'Chr', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfChr);
+ FFunctions.Add(etFunction, 'Iif', 3, 3, {$IFDEF FPC}@{$ENDIF}UdfIif);
+ FFunctions.Add(etFunction, 'Str', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfStr);
+ FFunctions.Add(etFunction, 'Val', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfVal);
+ FFunctions.Add(etFunction, 'Nul', 2, 2, {$IFDEF FPC}@{$ENDIF}UdfNul);
+ FFunctions.Add(etFunction, 'Now', 0, 0, {$IFDEF FPC}@{$ENDIF}UdfNow);
+ FFunctions.Add(etFunction, 'Frac', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfFrac);
+ FFunctions.Add(etFunction, 'Padr', 2, 2, {$IFDEF FPC}@{$ENDIF}UdfPadr);
+ FFunctions.Add(etFunction, 'Padl', 2, 2, {$IFDEF FPC}@{$ENDIF}UdfPadl);
+ FFunctions.Add(etFunction, 'Date', 0, 0, {$IFDEF FPC}@{$ENDIF}UdfDate);
+ FFunctions.Add(etFunction, 'Time', 0, 0, {$IFDEF FPC}@{$ENDIF}UdfTime);
+ FFunctions.Add(etFunction, 'Mid', 2, 3, {$IFDEF FPC}@{$ENDIF}UdfSubStr);
+ FFunctions.Add(etFunction, 'Copy', 2, 3, {$IFDEF FPC}@{$ENDIF}UdfSubStr);
+ FFunctions.Add(etFunction, 'SubStr', 2, 3, {$IFDEF FPC}@{$ENDIF}UdfSubStr);
+ FFunctions.Add(etFunction, 'Trunc', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfTrunc);
+ FFunctions.Add(etFunction, 'Round', 1, 2, {$IFDEF FPC}@{$ENDIF}UdfRound);
+ FFunctions.Add(etFunction, 'Upper', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfUpper);
+ FFunctions.Add(etFunction, 'Lower', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfLower);
+ FFunctions.Add(etFunction, 'Trim', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfTrim);
+ FFunctions.Add(etFunction, 'Empty', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfEmpty);
+ FFunctions.Add(etFunction, 'TrimLeft', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfTrimLeft);
+ FFunctions.Add(etFunction, 'TrimRight', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfTrimRight);
+ FFunctions.Add(etFunction, 'IntToStr', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfIntToStr);
+ FFunctions.Add(etFunction, 'StrToInt', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfStrToInt);
+ FFunctions.Add(etFunction, 'FloatToStr', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfFloatToStr);
+ FFunctions.Add(etFunction, 'StrToFloat', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfStrToFloat);
+ FFunctions.Add(etFunction, 'Power', 2, 2, {$IFDEF FPC}@{$ENDIF}UdfIntPower);
+ FFunctions.Add(etFunction, 'IntPower', 2, 2, {$IFDEF FPC}@{$ENDIF}UdfIntPower);
+ FFunctions.Add(etFunction, 'FormatFloat', 2, 2, {$IFDEF FPC}@{$ENDIF}UdfFormatFloat);
+ FFunctions.Add(etFunction, 'FBool', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfFbool);
+
+ //Dataset
+ FFunctions.Add(etFunction, 'Bof', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfBof);
+ FFunctions.Add(etFunction, 'Eof', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfEof);
+ FFunctions.Add(etProcedure, 'Next', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfNext);
+ FFunctions.Add(etProcedure, 'Prev', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfPrior);
+ FFunctions.Add(etProcedure, 'Open', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfOpen);
+ FFunctions.Add(etProcedure, 'First', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfFirst);
+ FFunctions.Add(etProcedure, 'Last', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfLast);
+ FFunctions.Add(etFunction, 'IsEmpty', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfIsEmpty);
+ FFunctions.Add(etFunction, 'RecordCount', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfRecordCount);
+ FFunctions.Add(etProcedure, 'Scan', 1, 9999, {$IFDEF FPC}@{$ENDIF}UdfScan);
+ FFunctions.Add(etProcedure, 'EndScan', 0, 0, {$IFDEF FPC}@{$ENDIF}UdfDummy);
+ FFunctions.Add(etProcedure, 'ScanEntry', 0, 0, {$IFDEF FPC}@{$ENDIF}UdfDummy);
+ FFunctions.Add(etProcedure, 'ScanFooter', 0, 0, {$IFDEF FPC}@{$ENDIF}UdfDummy);
+ FFunctions.Add(etProcedure, 'Dataset', 3, 9999, {$IFDEF FPC}@{$ENDIF}UdfDataset);
+
+ //Misc routines
+ FFunctions.Add(etProcedure, 'If', 1, 9999, {$IFDEF FPC}@{$ENDIF}UdfIf);
+ FFunctions.Add(etProcedure, 'Else', 0, 0, {$IFDEF FPC}@{$ENDIF}UdfDummy);
+ FFunctions.Add(etProcedure, 'Endif', 0, 0, {$IFDEF FPC}@{$ENDIF}UdfDummy);
+ FFunctions.Add(etProcedure, 'NoPar', 0, 0, {$IFDEF FPC}@{$ENDIF}UdfDummy);
+ FFunctions.Add(etFunction, 'Picture', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfPicture);
+ FFunctions.Add(etFunction, 'DbPicture', 1, 1, {$IFDEF FPC}@{$ENDIF}UdfDbPicture);
+end;
+
+procedure TtiRtfParser.UdfDummy(AArgument: TRtfArgument);
+begin
+ //Nothing, since its an etProcedure the Rtf paragraph will be removed
+end;
+
+procedure TtiRtfParser.UdfChr(AArgument: TRtfArgument);
+begin
+ if not AArgument.Check(0,[etLitInt])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ AArgument.Value := Chr(StrToInt(AArgument[0].Value));
+ AArgument.Token := etLitString;
+end;
+
+procedure TtiRtfParser.UdfNow(AArgument: TRtfArgument);
+begin
+ AArgument.Value := Now;
+ AArgument.Token := etLitDate;
+end;
+
+procedure TtiRtfParser.UdfDate(AArgument: TRtfArgument);
+begin
+ AArgument.Value := Date;
+ AArgument.Token := etLitDate;
+end;
+
+procedure TtiRtfParser.UdfTime(AArgument: TRtfArgument);
+begin
+ AArgument.Value := Time;
+ AArgument.Token := etLitDate;
+end;
+
+procedure TtiRtfParser.UdfIntToStr(AArgument: TRtfArgument);
+begin
+ if not AArgument.Check(0,[etLitInt])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ AArgument.Value := IntToStr(AArgument[0].Value);
+ AArgument.Token := etLitString;
+end;
+
+procedure TtiRtfParser.UdfStrToInt(AArgument: TRtfArgument);
+begin
+ if not AArgument.Check(0,[etLitString])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ AArgument.Value := StrToInt(AArgument[0].Value);
+ AArgument.Token := etLitInt;
+end;
+
+procedure TtiRtfParser.UdfFloatToStr(AArgument: TRtfArgument);
+begin
+ if not AArgument.Check(0,[etLitFloat])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ AArgument.Value := FloatToStr(Extended(AArgument[0].Value));
+ AArgument.Token := etLitString;
+end;
+
+procedure TtiRtfParser.UdfStrToFloat(AArgument: TRtfArgument);
+begin
+ if not AArgument.Check(0,[etLitString])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ AArgument.Value := StrToFloat(AArgument[0].Value);
+ AArgument.Token := etLitFloat;
+end;
+
+procedure TtiRtfParser.UdfNul(AArgument: TRtfArgument);
+var AStr: string;
+ ACnt: integer;
+begin
+ if not AArgument.Check([[etLitInt],[etLitInt]])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ AStr := AArgument[0].Value;
+ ACnt := AArgument[1].Value;
+ while Length(AStr) < ACnt do AStr := '0' + AStr;
+ while Length(AStr) > ACnt do Delete(AStr, 1, 1);
+ AArgument.Value := AStr;
+ AArgument.Token := etLitString;
+end;
+
+procedure TtiRtfParser.UdfPadl(AArgument: TRtfArgument);
+var AStr: string;
+ ACnt: integer;
+begin
+ if not AArgument.Check([[etLitString],[etLitInt]])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ AStr := AArgument[0].Value;
+ ACnt := AArgument[1].Value;
+ AStr := Copy(AStr, 1, ACnt);
+ while Length(AStr) < ACnt do begin
+ AStr := ' ' + AStr;
+ end;
+ AArgument.Value := AStr;
+ AArgument.Token := etLitString;
+end;
+
+procedure TtiRtfParser.UdfPadr(AArgument: TRtfArgument);
+var AStr: string;
+ ACnt: integer;
+begin
+ if not AArgument.Check([[etLitString],[etLitInt]])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ AStr := AArgument[0].Value;
+ ACnt := AArgument[1].Value;
+ AStr := Copy(AStr, 1, ACnt);
+ while Length(AStr) < ACnt do begin
+ AStr := AStr + ' ';
+ end;
+ AArgument.Value := AStr;
+ AArgument.Token := etLitString;
+end;
+
+procedure TtiRtfParser.UdfIif(AArgument: TRtfArgument);
+begin
+ if not AArgument.Check(0,[etLitFalse, etLitTrue])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ if AArgument[0].Token = etLitTrue then begin
+ AArgument.Value := AArgument[1].Value;
+ AArgument.Token := AArgument[1].Token;
+ end else begin
+ AArgument.Value := AArgument[2].Value;
+ AArgument.Token := AArgument[2].Token;
+ end;
+end;
+
+procedure TtiRtfParser.UdfIf(AArgument: TRtfArgument);
+begin
+ if not AArgument.Check(0,[etLitFalse, etLitTrue])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ AArgument.Value := AArgument[0].Value;
+ AArgument.Token := AArgument[0].Token;
+end;
+
+procedure TtiRtfParser.UdfScan(AArgument: TRtfArgument);
+begin
+ if not AArgument.Check(0,[etDataset])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ AArgument.Value := AArgument[0].Value;
+ AArgument.Token := AArgument[0].Token;
+ if AArgument.Count > 1 then begin
+ if AArgument[1].Token = etLitTrue
+ then AArgument.Param := 1;
+ end;
+end;
+
+procedure TtiRtfParser.UdfDataset(AArgument: TRtfArgument);
+var ADatabase, AAliasName, ASqlScript: string;
+ ADataset: TRtfDataset;
+ AObject: TObject;
+begin
+ if not AArgument.Check([[etLitString],[etLitString],[etLitString]])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+
+ ADatabase := AArgument[0].Value;
+ AAliasName := AArgument[1].Value;
+ ASqlScript := AArgument[2].Value;
+
+ //Delete first argument so Sql params become first
+ AArgument.Delete(0);
+ AArgument.Delete(0);
+ AArgument.Delete(0);
+
+ //Remove existing dataset with same aliasname
+ ADataset := Datasets.Find(AAliasName);
+ if Assigned(ADataset)
+ then Datasets.Remove(ADataset);
+
+ //Create the new query or dataset (whatever)
+ if Assigned(OnCreateDataset)
+ then OnCreateDataset(ADatabase, AAliasName, ASqlScript, AArgument)
+ else raise TRtfException.Create('OnCreateDataset is not assigned');
+ if VarIsEmpty(AArgument.Value)
+ then raise TRtfException.Create('OnCreateDataset did not return a dataset object');
+
+ AObject := TObject(integer(AArgument.Value));
+ ADataset := Datasets.Add(AObject, AAliasname, true);
+ AArgument.Token := etDataset;
+ AArgument.Value := integer(ADataset);
+end;
+
+procedure TtiRtfParser.UdfLower(AArgument: TRtfArgument);
+begin
+ if not AArgument.Check(0,[etLitString])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ AArgument.Token := etLitString;
+ AArgument.Value := LowerCase(AArgument[0].Value);
+end;
+
+procedure TtiRtfParser.UdfUpper(AArgument: TRtfArgument);
+begin
+ if not AArgument.Check(0,[etLitString])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ AArgument.Token := etLitString;
+ AArgument.Value := UpperCase(AArgument[0].Value);
+end;
+
+procedure TtiRtfParser.UdfTrim(AArgument: TRtfArgument);
+begin
+ if not AArgument.Check(0,[etLitString])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ AArgument.Token := etLitString;
+ AArgument.Value := Trim(AArgument[0].Value);
+end;
+
+procedure TtiRtfParser.UdfTrimLeft(AArgument: TRtfArgument);
+begin
+ if not AArgument.Check(0,[etLitString])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ AArgument.Token := etLitString;
+ AArgument.Value := TrimLeft(AArgument[0].Value);
+end;
+
+procedure TtiRtfParser.UdfTrimRight(AArgument: TRtfArgument);
+begin
+ if not AArgument.Check(0,[etLitString])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ AArgument.Token := etLitString;
+ AArgument.Value := TrimRight(AArgument[0].Value);
+end;
+
+procedure TtiRtfParser.UdfSubStr(AArgument: TRtfArgument);
+var AStr: string;
+ APos, ACnt: integer;
+begin
+ ACnt := Maxint;
+ if not AArgument.Check([[etLitString],[etLitInt]])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ if AArgument.Count > 2 then begin
+ if not AArgument.Check(2,[etLitInt]) then
+ raise TRtfException.Create(rsUnexpectedParameterType);
+ ACnt := AArgument[2].Value;
+ end;
+ AStr := AArgument[0].Value;
+ APos := AArgument[1].Value;
+ AStr := Copy(AStr, APos, ACnt);
+ AArgument.Value := AStr;
+ AArgument.Token := etLitString;
+end;
+
+procedure TtiRtfParser.UdfStr(AArgument: TRtfArgument);
+begin
+ if not AArgument.Check(0,[etLitFloat, etLitInt]) then
+ raise TRtfException.Create(rsUnexpectedParameterType);
+ if AArgument[0].Token = etLitFloat then
+ begin
+ AArgument.Token := etLitString;
+ AArgument.Value := FloatToStr(AArgument[0].Value);
+ end
+ else
+ begin
+ AArgument.Token := etLitString;
+ AArgument.Value := IntToStr(AArgument[0].Value);
+ end;
+end;
+
+procedure TtiRtfParser.UdfVal(AArgument: TRtfArgument);
+begin
+ if not AArgument.Check(0,[etLitString]) then
+ raise TRtfException.Create(rsUnexpectedParameterType);
+ if (Pos('.', AArgument[0].Value) > 0)or(Pos(',', AArgument[0].Value) > 0) then
+ begin
+ AArgument.Token := etLitString;
+ AArgument.Value := StrToFloat(AArgument[0].Value)
+ end
+ else
+ begin
+ AArgument.Token := etLitString;
+ AArgument.Value := StrToInt(AArgument[0].Value)
+ end;
+end;
+
+procedure TtiRtfParser.UdfBof(AArgument: TRtfArgument);
+var ATable: TRtfDataset;
+begin
+ if not AArgument.Check(0,[etDataset]) then
+ raise TRtfException.Create(rsUnexpectedParameterType);
+ ATable := TRtfDataset(integer(AArgument[0].Value));
+ if ATable.Bof then
+ begin
+ AArgument.Token := etLitTrue;
+ AArgument.Value := true;
+ end
+ else
+ begin
+ AArgument.Token := etLitFalse;
+ AArgument.Value := false;
+ end;
+end;
+
+procedure TtiRtfParser.UdfEof(AArgument: TRtfArgument);
+var ATable: TRtfDataset;
+begin
+ if not AArgument.Check(0,[etDataset]) then
+ raise TRtfException.Create(rsUnexpectedParameterType);
+ ATable := TRtfDataset(integer(AArgument[0].Value));
+ if ATable.Eof then
+ begin
+ AArgument.Token := etLitTrue;
+ AArgument.Value := true;
+ end
+ else
+ begin
+ AArgument.Token := etLitFalse;
+ AArgument.Value := false;
+ end;
+end;
+
+
+procedure TtiRtfParser.UdfRecordCount(AArgument: TRtfArgument);
+var ATable: TRtfDataset;
+begin
+ if not AArgument.Check(0,[etDataset])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ ATable := TRtfDataset(integer(AArgument[0].Value));
+ AArgument.Token := etLitInt;
+ AArgument.Value := ATable.RecordCount
+end;
+
+procedure TtiRtfParser.UdfIsEmpty(AArgument: TRtfArgument);
+var ATable: TRtfDataset;
+begin
+ if not AArgument.Check(0,[etDataset])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ ATable := TRtfDataset(integer(AArgument[0].Value));
+ if ATable.IsEmpty then begin
+ AArgument.Token := etLitTrue;
+ AArgument.Value := true;
+ end else begin
+ AArgument.Token := etLitFalse;
+ AArgument.Value := false;
+ end;
+end;
+
+procedure TtiRtfParser.UdfFirst(AArgument: TRtfArgument);
+var ATable: TRtfDataset;
+begin
+ if not AArgument.Check(0,[etDataset])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ ATable := TRtfDataset(integer(AArgument[0].Value));
+ ATable.First;
+end;
+
+procedure TtiRtfParser.UdfLast(AArgument: TRtfArgument);
+var ATable: TRtfDataset;
+begin
+ if not AArgument.Check(0,[etDataset])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ ATable := TRtfDataset(integer(AArgument[0].Value));
+ ATable.Last;
+end;
+
+procedure TtiRtfParser.UdfNext(AArgument: TRtfArgument);
+var ATable: TRtfDataset;
+begin
+ if not AArgument.Check(0,[etDataset])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ ATable := TRtfDataset(integer(AArgument[0].Value));
+ ATable.Next;
+end;
+
+procedure TtiRtfParser.UdfOpen(AArgument: TRtfArgument);
+var ATable: TRtfDataset;
+begin
+ if not AArgument.Check(0,[etDataset])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ ATable := TRtfDataset(integer(AArgument[0].Value));
+ ATable.Open;
+end;
+
+procedure TtiRtfParser.UdfPrior(AArgument: TRtfArgument);
+var ATable: TRtfDataset;
+begin
+ if not AArgument.Check(0,[etDataset])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ ATable := TRtfDataset(integer(AArgument[0].Value));
+ ATable.Prior;
+end;
+
+procedure TtiRtfParser.UdfInt(AArgument: TRtfArgument);
+//Returns the integer part of a float
+begin
+ if not AArgument.Check(0,[etLitFloat, etLitInt])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ if AArgument[0].Token = etLitFloat then begin
+ AArgument.Token := etLitFloat;
+ AArgument.Value := Int(AArgument[0].Value);
+ end else begin
+ AArgument.Token := etLitInt;
+ AArgument.Value := AArgument[0].Value;
+ end;
+end;
+
+procedure TtiRtfParser.UdfFrac(AArgument: TRtfArgument);
+//Returns the fractional part of a float
+begin
+ if not AArgument.Check(0,[etLitFloat, etLitInt])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ if AArgument[0].Token = etLitFloat then begin
+ AArgument.Token := etLitFloat;
+ AArgument.Value := Frac(AArgument[0].Value);
+ end else begin
+ AArgument.Token := etLitInt;
+ AArgument.Value := 0;
+ end;
+end;
+
+procedure TtiRtfParser.UdfRound(AArgument: TRtfArgument);
+//0.5 is always rounded to largest integer number
+var
+ ASign, ADecimals, AInt: integer;
+ AFloat, APower, AFrac: Double;
+begin
+ ADecimals := 0;
+ if not AArgument.Check(0,[etLitFloat, etLitInt]) then
+ raise TRtfException.Create(rsUnexpectedParameterType);
+ if AArgument.Count > 1 then
+ begin
+ if not AArgument.Check(1,[etLitInt]) then
+ raise TRtfException.Create(rsUnexpectedParameterType);
+ ADecimals := AArgument[1].Value;
+ end;
+
+ if AArgument[0].Token = etLitFloat then
+ begin
+ AFloat := AArgument[0].Value;
+
+ ASign := 1;
+ if AFloat < 0 then
+ begin
+ AFloat := - AFloat;
+ ASign := - 1;
+ end;
+
+ if ADecimals = 0 then
+ begin
+ AInt := Trunc(AFloat); //integer part
+ AFrac := AFloat - AInt; //fractional part
+ if AFrac >= 0.5 then
+ AArgument.Value := ASign *(AInt + 1)
+ else
+ AArgument.Value := ASign * AInt;
+ AArgument.Token := etLitFloat;
+ end
+ else
+ begin
+ APower := IntPower(10, ADecimals);
+ AInt := Trunc(AFloat * APower); //integer part * 10^ADecimals
+ AFrac := AFloat * APower - AInt; //fractional part
+ if AFrac >= 0.5 then
+ AArgument.Value := ASign * IntPower(10, - ADecimals) *(AInt + 1)
+ else
+ AArgument.Value := ASign * IntPower(10, - ADecimals) * AInt;
+ AArgument.Token := etLitFloat;
+ end;
+ end
+ else
+ begin
+ AArgument.Token := etLitInt;
+ AArgument.Value := AArgument[0].Value;
+ end;
+end;
+
+procedure TtiRtfParser.UdfTrunc(AArgument: TRtfArgument);
+begin
+ if not AArgument.Check(0,[etLitFloat, etLitInt])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ if AArgument[0].Token = etLitFloat then begin
+ AArgument.Token := etLitFloat;
+ AArgument.Value := Trunc(AArgument[0].Value);
+ end else begin
+ AArgument.Token := etLitInt;
+ AArgument.Value := AArgument[0].Value;
+ end;
+end;
+
+procedure TtiRtfParser.UdfIntPower(AArgument: TRtfArgument);
+var AFloat: Double;
+ AExponent: integer;
+begin
+ if not AArgument.Check([[etLitInt, etLitFloat],[etLitInt]]) then
+ raise TRtfException.Create(rsUnexpectedParameterType);
+ AFloat := AArgument[0].Value;
+ AExponent := AArgument[1].Value;
+ AArgument.Token := etLitFloat;
+ AArgument.Value := IntPower(AFloat, AExponent);
+end;
+
+procedure TtiRtfParser.UdfPower(AArgument: TRtfArgument);
+var AFloat, AExponent: Double;
+begin
+ if not AArgument.Check([[etLitInt, etLitFloat],[etLitInt, etLitFloat]])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ AFloat := AArgument[0].Value;
+ AExponent := AArgument[1].Value;
+ AArgument.Token := etLitFloat;
+ AArgument.Value := Pwr(AFloat, AExponent);
+end;
+
+procedure TtiRtfParser.UdfEmpty(AArgument: TRtfArgument);
+begin
+ if not AArgument.Check(0,[etLitString])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ if Trim(AArgument[0].Value) = '' then begin
+ AArgument.Token := etLitTrue;
+ AArgument.Value := true;
+ end else begin
+ AArgument.Token := etLitFalse;
+ AArgument.Value := false;
+ end;
+end;
+
+procedure TtiRtfParser.UdfDay(AArgument: TRtfArgument);
+var AYear, AMonth, ADay: word;
+begin
+ if not AArgument.Check(0,[etLitDate])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ DecodeDate(AArgument[0].Value, AYear, AMonth, ADay);
+ AArgument.Token := etLitInt;
+ AArgument.Value := AYear;
+end;
+
+procedure TtiRtfParser.UdfMonth(AArgument: TRtfArgument);
+var AYear, AMonth, ADay: word;
+begin
+ if not AArgument.Check(0,[etLitDate])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ DecodeDate(AArgument[0].Value, AYear, AMonth, ADay);
+ AArgument.Token := etLitInt;
+ AArgument.Value := AMonth;
+end;
+
+procedure TtiRtfParser.UdfYear(AArgument: TRtfArgument);
+var AYear, AMonth, ADay: word;
+begin
+ if not AArgument.Check(0,[etLitDate])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ DecodeDate(AArgument[0].Value, AYear, AMonth, ADay);
+ AArgument.Token := etLitInt;
+ AArgument.Value := ADay;
+end;
+
+procedure TtiRtfParser.UdfShortDayName(AArgument: TRtfArgument);
+var AYear, AMonth, ADay: word;
+begin
+ if not AArgument.Check(0,[etLitDate])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ DecodeDate(AArgument[0].Value, AYear, AMonth, ADay);
+ AArgument.Token := etLitString;
+ AArgument.Value := ShortDayNames[ADay];
+end;
+
+procedure TtiRtfParser.UdfShortMonthName(AArgument: TRtfArgument);
+var AYear, AMonth, ADay: word;
+begin
+ if not AArgument.Check(0,[etLitDate])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ DecodeDate(AArgument[0].Value, AYear, AMonth, ADay);
+ AArgument.Token := etLitString;
+ AArgument.Value := ShortMonthNames[AMonth];
+end;
+
+procedure TtiRtfParser.UdfLongDayName(AArgument: TRtfArgument);
+var AYear, AMonth, ADay: word;
+begin
+ if not AArgument.Check(0,[etLitDate])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ DecodeDate(AArgument[0].Value, AYear, AMonth, ADay);
+ AArgument.Token := etLitString;
+ AArgument.Value := LongMonthNames[AMonth];
+end;
+
+procedure TtiRtfParser.UdfLongMonthName(AArgument: TRtfArgument);
+var AYear, AMonth, ADay: word;
+begin
+ if not AArgument.Check(0,[etLitDate])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ DecodeDate(AArgument[0].Value, AYear, AMonth, ADay);
+ AArgument.Token := etLitString;
+ AArgument.Value := LongMonthNames[AMonth];
+end;
+
+procedure TtiRtfParser.UdfSDay(AArgument: TRtfArgument);
+var AYear, AMonth, ADay: word;
+begin
+ if not AArgument.Check(0,[etLitDate])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ DecodeDate(AArgument[0].Value, AYear, AMonth, ADay);
+ AArgument.Token := etLitString;
+ AArgument.Value := Format('%0.4d',[AYear]);
+end;
+
+procedure TtiRtfParser.UdfSMonth(AArgument: TRtfArgument);
+var AYear, AMonth, ADay: word;
+begin
+ if not AArgument.Check(0,[etLitDate])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ DecodeDate(AArgument[0].Value, AYear, AMonth, ADay);
+ AArgument.Token := etLitString;
+ AArgument.Value := Format('%0.2d',[AMonth]);
+end;
+
+procedure TtiRtfParser.UdfSYear(AArgument: TRtfArgument);
+var AYear, AMonth, ADay: word;
+begin
+ if not AArgument.Check(0,[etLitDate])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ DecodeDate(AArgument[0].Value, AYear, AMonth, ADay);
+ AArgument.Token := etLitString;
+ AArgument.Value := Format('%0.2d',[ADay]);
+end;
+
+procedure TtiRtfParser.UdfStod(AArgument: TRtfArgument);
+var AYear, AMonth, ADay: word;
+ AStr: string;
+begin
+ if not AArgument.Check(0,[etLitString])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ AStr := AArgument[0].Value;
+ AYear := StrToInt(Copy(AStr, 1, 4));
+ AMonth := StrToInt(Copy(AStr, 5, 2));
+ ADay := StrToInt(Copy(AStr, 7, 2));
+ AArgument.Token := etLitDate;
+ AArgument.Value := EncodeDate(AYear, AMonth, ADay);
+end;
+
+procedure TtiRtfParser.UdfDateTimeTo(AArgument: TRtfArgument; AFormat: string);
+begin
+ if not AArgument.Check(0,[etLitDate]) then
+ raise TRtfException.Create(rsUnexpectedParameterType);
+ if AArgument.Count > 1 then
+ begin
+ if not AArgument.Check(1,[etLitString]) then
+ raise TRtfException.Create(rsUnexpectedParameterType);
+ AFormat := AArgument[1].Value;
+ end;
+ AArgument.Token := etLitString;
+ AArgument.Value := FormatDateTime(AFormat, AArgument[0].Value);
+end;
+
+procedure TtiRtfParser.UdfDtos(AArgument: TRtfArgument);
+begin
+ UdfDateTimeTo(AArgument, 'YYYYMMDD');
+end;
+
+procedure TtiRtfParser.UdfDateToStr(AArgument: TRtfArgument);
+begin
+ UdfDateTimeTo(AArgument, ShortDateFormat);
+end;
+
+procedure TtiRtfParser.UdfTimeToStr(AArgument: TRtfArgument);
+begin
+ UdfDateTimeTo(AArgument, ShortTimeFormat);
+end;
+
+procedure TtiRtfParser.UdfDateTimeToStr(AArgument: TRtfArgument);
+begin
+ UdfDateTimeTo(AArgument, ShortDateFormat + ' ' + ShortTimeFormat);
+end;
+
+procedure TtiRtfParser.UdfStrToDate(AArgument: TRtfArgument);
+begin
+ if not AArgument.Check(0,[etLitString]) then
+ raise TRtfException.Create(rsUnexpectedParameterType);
+ AArgument.Token := etLitString;
+ AArgument.Value := StrToDate(AArgument[0].Value);
+end;
+
+procedure TtiRtfParser.UdfStrToTime(AArgument: TRtfArgument);
+begin
+ if not AArgument.Check(0,[etLitString])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ AArgument.Token := etLitString;
+ AArgument.Value := StrToTime(AArgument[0].Value);
+end;
+
+procedure TtiRtfParser.UdfStrToDateTime(AArgument: TRtfArgument);
+begin
+ if not AArgument.Check(0,[etLitString])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ AArgument.Token := etLitString;
+ AArgument.Value := StrToDateTime(AArgument[0].Value);
+end;
+
+procedure TtiRtfParser.UdfFormatFloat(AArgument: TRtfArgument);
+var AFormat: string;
+ AFloat: Double;
+begin
+ if not AArgument.Check([[etLitString],[etLitFloat, etLitInt]]) then
+ raise TRtfException.Create(rsUnexpectedParameterType);
+ AFormat := AArgument[0].Value;
+ AFloat := AArgument[1].Value;
+ AArgument.Token := etLitString;
+ AArgument.Value := FormatFloat(AFormat, AFloat);
+end;
+
+procedure TtiRtfParser.UdfFBool(AArgument: TRtfArgument);
+begin
+ if not AArgument.Check(0,[etLitFalse, etLitTrue]) then
+ raise TRtfException.Create(rsUnexpectedParameterType);
+ if AArgument[0].Token = etLitFalse then
+ begin
+ AArgument.Token := etLitString;
+ AArgument.Value := BoolFalse;
+ end else begin
+ AArgument.Token := etLitString;
+ AArgument.Value := BoolTrue;
+ end;
+end;
+
+procedure TtiRtfParser.UdfPicture(AArgument: TRtfArgument);
+var
+ APicture: TPicture;
+ AFilename: string;
+begin
+(*
+ if not AArgument.Check(0,[etLitString])
+ then raise TRtfException.Create(rsUnexpectedParameterType);
+ APicture := TPicture.Create;
+ try
+ AFilename := AArgument[0].Value;
+ if Assigned(OnPicturePath)
+ then OnPicturePath(AFilename);
+
+ APicture.LoadFromFile(AFilename);
+ if not Assigned(APicture.Graphic)or APicture.Graphic.Empty then begin
+ AArgument.Token := etNothing;
+ AArgument.Value := varEmpty;
+ end else begin
+ AArgument.Value := AArgument.GetPicture(APicture);
+ AArgument.Token := etLitString;
+ end;
+ finally
+ APicture.Free;
+ end;
+ *)
+end;
+
+procedure TtiRtfParser.UdfDbPicture(AArgument: TRtfArgument);
+//Since a simple blob (not ftGraphic field) can contain an image
+//It has become kind of a typecast for a dataset field.
+var ADataset: TRtfDataset;
+ AFieldName: string;
+begin
+ if not AArgument.Check(0,[etFieldName]) then
+ raise TRtfException.Create(rsUnexpectedParameterType);
+ ADataset := Datasets.Find(AArgument[0].Value, AFieldName);
+ if not Assigned(ADataset) then //There should be at least a table reference.
+ raise TRtfException.Create('Dataset not found');
+ AArgument.GetGraphicsValue(ADataset, AFieldName);
+end;
+
+end.
+
+
+
+
+
diff --git a/extras/tiopf/mvp/basic_intf.pas b/extras/tiopf/mvp/basic_intf.pas
index 36f56f32..a569db9a 100644
--- a/extras/tiopf/mvp/basic_intf.pas
+++ b/extras/tiopf/mvp/basic_intf.pas
@@ -17,13 +17,13 @@ type
IObserver = interface(IInterface)
- ['{16CD208B-5F37-41FC-82A4-BFDD16DB3203}']
+ ['{16CD208B-5F37-41FC-82A4-BFDD16DB3203}']
procedure Update(const ASubject: IInterface);
end;
-
+
ISubject = interface(IInterface)
- ['{004B3299-C221-4A44-87A7-7657D90B6493}']
+ ['{004B3299-C221-4A44-87A7-7657D90B6493}']
procedure Attach(Observer: IObserver);
procedure Detach(Observer: IObserver);
procedure Notify;
@@ -33,18 +33,18 @@ type
IVisitor = interface(IInterface)
- ['{35E154D2-6573-42DA-9854-156F3B19C95F}']
+ ['{35E154D2-6573-42DA-9854-156F3B19C95F}']
// empty interface
end;
IVisited = interface(IInterface)
- ['{7CF62F51-9412-445C-9E8C-DE94F2B1E280}']
+ ['{7CF62F51-9412-445C-9E8C-DE94F2B1E280}']
procedure Accept(const Visitor: IVisitor);
end;
IListModel = interface(IInterface)
- ['{1A772375-1263-4790-8827-F7BEA358674A}']
+ ['{1A772375-1263-4790-8827-F7BEA358674A}']
function GetCount: Integer;
function GetItem(Idx: Integer): IInterface;
procedure Add(const Item: IInterface);
@@ -59,7 +59,7 @@ type
(*
IController = interface(IInterface)
- ['{4A99C01A-D025-4562-8E94-3A0C873CE894}']
+ ['{4A99C01A-D025-4562-8E94-3A0C873CE894}']
function GetModel: IModel;
function GetView: IView;
procedure SetModel(const AValue: IModel);
@@ -70,7 +70,7 @@ type
*)
IString = interface(IInterface)
- ['{E76984A4-1287-4353-8370-A7332B9FB1CB}']
+ ['{E76984A4-1287-4353-8370-A7332B9FB1CB}']
function GetAsString: string;
procedure SetAsString(const AValue: string);
property AsString: string read GetAsString write SetAsString;
@@ -78,14 +78,14 @@ type
IStringListModel = interface(IListModel)
- ['{769804CD-89E4-43C7-B8EF-783BFE27214E}']
+ ['{769804CD-89E4-43C7-B8EF-783BFE27214E}']
function GetItem(Idx: Integer): IString; overload;
property Item[Idx: Integer]: IString read GetItem;
end;
ISelection = interface(IInterface)
- ['{F4DDA0EA-E982-4785-8602-5B32E8DD6DA2}']
+ ['{F4DDA0EA-E982-4785-8602-5B32E8DD6DA2}']
procedure AddItem(const Item: IInterface);
procedure Clear;
function GetCount: integer;
@@ -95,7 +95,7 @@ type
ICommand = interface(IInterface)
- ['{B333C7E1-B124-4D08-A640-DC02F36264C7}']
+ ['{B333C7E1-B124-4D08-A640-DC02F36264C7}']
procedure BindSelection(const Selection: ISelection);
function Execute: Boolean;
function GetEnabled: Boolean;
@@ -106,25 +106,25 @@ type
ICommandSet = interface(IInterface)
- ['{1622FF69-3104-47EA-8741-9C1B05ADA30B}']
+ ['{1622FF69-3104-47EA-8741-9C1B05ADA30B}']
// empty interface
end;
ICommandVisitor = interface(IVisitor)
- ['{628B3A4A-30D1-48D3-8B46-090F08AD2AC8}']
+ ['{628B3A4A-30D1-48D3-8B46-090F08AD2AC8}']
procedure VisitComand(const Command: ICommand);
end;
ICommandMenu = interface(IInterface)
- ['{3C666D8F-6BED-454B-8BFE-28422943B300}']
+ ['{3C666D8F-6BED-454B-8BFE-28422943B300}']
function AddItem(const Caption: string; Enabled: Boolean): ICommandMenuItem;
end;
ICommandMenuItem = interface(IInterface)
- ['{7DFCF2BD-70DA-4DAC-B8D5-C6FB882267CF}']
+ ['{7DFCF2BD-70DA-4DAC-B8D5-C6FB882267CF}']
function GetCaption: string;
function GetChecked: Boolean;
function GetCommand: ICommand;
@@ -138,7 +138,7 @@ type
IStringVisitor = interface(IVisitor)
- ['{DA12355F-0727-41B3-9080-DDAF20797FC5}']
+ ['{DA12355F-0727-41B3-9080-DDAF20797FC5}']
function GetTheString: IString;
procedure VisitString(const Str: IString);
property TheString: IString
@@ -147,7 +147,7 @@ type
IMVPModel = interface(IInterface)
- ['{85223140-B263-4413-89E3-BFA37E9D3112}']
+ ['{85223140-B263-4413-89E3-BFA37E9D3112}']
function GetCommandSet: ICommandSet;
function GetCurrentSelection: ISelection;
property CommandSet: ICommandSet read GetCommandSet;
@@ -156,7 +156,7 @@ type
IMVPPresenter = interface(IInterface)
- ['{5B8477DA-A006-4DE1-B304-9512BFAD7507}']
+ ['{5B8477DA-A006-4DE1-B304-9512BFAD7507}']
function GetCommandMenu: ICommandMenu;
function GetModel: IMVPModel;
function GetView: IMVPView;
@@ -170,14 +170,14 @@ type
IMVPView = interface(IInterface)
- ['{2C575FE7-BACD-46EC-9D72-AEDA44836B20}']
+ ['{2C575FE7-BACD-46EC-9D72-AEDA44836B20}']
procedure AdoptCommandMenu(const Value: ICommandMenu);
procedure OrphanCommandMenu(const Value: ICommandMenu);
end;
IStringListView = interface(IMVPView)
- ['{D834710A-9C1A-42D1-A29B-7F9F8FB46426}']
+ ['{D834710A-9C1A-42D1-A29B-7F9F8FB46426}']
function GetOnSelectString: TSelectStringEvent;
procedure SetOnSelectString(const AValue: TSelectStringEvent);
property OnSelectString: TSelectStringEvent read GetOnSelectString write SetOnSelectString;
@@ -185,7 +185,7 @@ type
IStringMoveVisitor = interface(IStringVisitor)
- ['{DB89C96F-DA90-43ED-A621-51B70E6C600E}']
+ ['{DB89C96F-DA90-43ED-A621-51B70E6C600E}']
function GetCanDemote: Boolean;
function GetCanPromote: Boolean;
property CanDemote: Boolean read GetCanDemote;
diff --git a/extras/tiopf/mvp/fpgui_intf.pas b/extras/tiopf/mvp/fpgui_intf.pas
index f6e9e4ca..fea8b153 100644
--- a/extras/tiopf/mvp/fpgui_intf.pas
+++ b/extras/tiopf/mvp/fpgui_intf.pas
@@ -10,7 +10,7 @@ uses
type
IPopupCommandMenu = interface(IInterface)
- ['{812C1940-A8BD-4BB4-AE8D-37A912D44A6D}']
+ ['{812C1940-A8BD-4BB4-AE8D-37A912D44A6D}']
function GetMenu: TfpgPopupMenu;
procedure SetMenu(const AValue: TfpgPopupMenu);
property Menu: TfpgPopupMenu read GetMenu write SetMenu;
diff --git a/extras/tiopf/tiOPFfpGUI.lpk b/extras/tiopf/tiOPFfpGUI.lpk
index 663bee3b..5906feb0 100644
--- a/extras/tiopf/tiOPFfpGUI.lpk
+++ b/extras/tiopf/tiOPFfpGUI.lpk
@@ -21,7 +21,7 @@
<License Value="Mozilla Public License v1.1
"/>
<Version Major="2" Release="4"/>
- <Files Count="7">
+ <Files Count="8">
<Item1>
<Filename Value="gui/tiGUIUtils.pas"/>
<UnitName Value="tiGUIUtils"/>
@@ -50,6 +50,10 @@
<Filename Value="gui/tiCompositeMediators.pas"/>
<UnitName Value="tiCompositeMediators"/>
</Item7>
+ <Item8>
+ <Filename Value="gui/tiRtfReport.pas"/>
+ <UnitName Value="tiRtfReport"/>
+ </Item8>
</Files>
<RequiredPkgs Count="3">
<Item1>
diff --git a/extras/tiopf/tiOPFfpGUI.pas b/extras/tiopf/tiOPFfpGUI.pas
index b7d5cc8b..8ca8f183 100644
--- a/extras/tiopf/tiOPFfpGUI.pas
+++ b/extras/tiopf/tiOPFfpGUI.pas
@@ -8,7 +8,7 @@ interface
uses
tiGUIUtils, tiDialogs, tiGUIINI, tiGenericEditMediators, tiGUIConstants,
- tiGenericListMediators, tiCompositeMediators;
+ tiGenericListMediators, tiCompositeMediators, tiRtfReport;
implementation
generated by cgit v1.2.3-70-g09d2 (git 2.47.1) at 2024-12-27 13:21:34 +0000