From 99be9f9acbf25d77910fe946226a729a6d2daa9e Mon Sep 17 00:00:00 2001 From: graemeg Date: Fri, 18 Apr 2008 15:02:49 +0000 Subject: * Ported a RTF Reporting Engine for tiOPF and fpGUI. It's still missing Image support, but other than that, it's working nicely. A demo will be added soon. --- extras/tiopf/gui/tiRtfReport.pas | 4632 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 4632 insertions(+) create mode 100644 extras/tiopf/gui/tiRtfReport.pas (limited to 'extras/tiopf/gui/tiRtfReport.pas') 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 <<< 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. + + + + + -- cgit v1.2.3-70-g09d2