From b15721dd9bee9356f64fe85ff8c989d564abb3d4 Mon Sep 17 00:00:00 2001 From: wp_xxyyzz Date: Wed, 2 Jul 2014 22:03:03 +0000 Subject: [PATCH] fpspreadsheet: Allow to register user-provided functions for calculation of rpn formulas for which fpspreadsheet does not have a built-in calculation method (example: financial functions). Add example "test_formula_func" in folder "other". git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@3270 8e941d3f-bd1b-0410-a28a-d453659cc2b4 --- .../examples/other/test_formula_func.lpi | 103 +++++++++++ .../examples/other/test_formula_func.lps | 169 ++++++++++++++++++ .../examples/other/test_formula_func.pas | 126 +++++++++++++ components/fpspreadsheet/fpsfunc.pas | 1 + components/fpspreadsheet/fpspreadsheet.pas | 93 +++++++++- 5 files changed, 487 insertions(+), 5 deletions(-) create mode 100644 components/fpspreadsheet/examples/other/test_formula_func.lpi create mode 100644 components/fpspreadsheet/examples/other/test_formula_func.lps create mode 100644 components/fpspreadsheet/examples/other/test_formula_func.pas diff --git a/components/fpspreadsheet/examples/other/test_formula_func.lpi b/components/fpspreadsheet/examples/other/test_formula_func.lpi new file mode 100644 index 000000000..fc36ab53f --- /dev/null +++ b/components/fpspreadsheet/examples/other/test_formula_func.lpi @@ -0,0 +1,103 @@ + + + + + + + + + + + + + + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="2"> + <Item1 Name="Debug" Default="True"/> + <Item2 Name="Release"> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + </SearchPaths> + <CodeGeneration> + <SmartLinkUnit Value="True"/> + </CodeGeneration> + <Linking> + <Debugging> + <StripSymbols Value="True"/> + </Debugging> + <LinkSmart Value="True"/> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + </CompilerOptions> + </Item2> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <RequiredPackages Count="1"> + <Item1> + <PackageName Value="laz_fpspreadsheet"/> + </Item1> + </RequiredPackages> + <Units Count="1"> + <Unit0> + <Filename Value="test_formula_func.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="test_formula_func"/> + </Unit0> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + </SearchPaths> + <CodeGeneration> + <SmartLinkUnit Value="True"/> + </CodeGeneration> + <Linking> + <Debugging> + <DebugInfoType Value="dsDwarf2Set"/> + </Debugging> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/components/fpspreadsheet/examples/other/test_formula_func.lps b/components/fpspreadsheet/examples/other/test_formula_func.lps new file mode 100644 index 000000000..0ec4f0d76 --- /dev/null +++ b/components/fpspreadsheet/examples/other/test_formula_func.lps @@ -0,0 +1,169 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectSession> + <PathDelim Value="\"/> + <Version Value="9"/> + <BuildModes Active="Debug"/> + <Units Count="4"> + <Unit0> + <Filename Value="test_formula_func.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="test_formula_func"/> + <IsVisibleTab Value="True"/> + <TopLine Value="65"/> + <CursorPos X="47" Y="97"/> + <UsageCount Value="20"/> + <Loaded Value="True"/> + </Unit0> + <Unit1> + <Filename Value="..\..\fpspreadsheet.pas"/> + <UnitName Value="fpspreadsheet"/> + <EditorIndex Value="3"/> + <TopLine Value="2942"/> + <CursorPos Y="2961"/> + <UsageCount Value="10"/> + <Loaded Value="True"/> + </Unit1> + <Unit2> + <Filename Value="..\..\fpsfunc.pas"/> + <UnitName Value="fpsfunc"/> + <EditorIndex Value="2"/> + <TopLine Value="24"/> + <CursorPos Y="50"/> + <UsageCount Value="10"/> + <Loaded Value="True"/> + </Unit2> + <Unit3> + <Filename Value="..\..\fpsutils.pas"/> + <UnitName Value="fpsutils"/> + <EditorIndex Value="1"/> + <TopLine Value="876"/> + <CursorPos Y="894"/> + <UsageCount Value="10"/> + <Loaded Value="True"/> + </Unit3> + </Units> + <JumpHistory Count="30" HistoryIndex="29"> + <Position1> + <Filename Value="..\..\fpspreadsheet.pas"/> + <Caret Line="2988" TopLine="2960"/> + </Position1> + <Position2> + <Filename Value="..\..\fpspreadsheet.pas"/> + <Caret Line="2987" TopLine="2960"/> + </Position2> + <Position3> + <Filename Value="..\..\fpsutils.pas"/> + <Caret Line="853" TopLine="836"/> + </Position3> + <Position4> + <Filename Value="..\..\fpsutils.pas"/> + <Caret Line="854" TopLine="836"/> + </Position4> + <Position5> + <Filename Value="..\..\fpsutils.pas"/> + <Caret Line="855" TopLine="836"/> + </Position5> + <Position6> + <Filename Value="..\..\fpsutils.pas"/> + <Caret Line="856" TopLine="836"/> + </Position6> + <Position7> + <Filename Value="..\..\fpsutils.pas"/> + <Caret Line="858" TopLine="836"/> + </Position7> + <Position8> + <Filename Value="..\..\fpsutils.pas"/> + <Caret Line="860" TopLine="836"/> + </Position8> + <Position9> + <Filename Value="..\..\fpsutils.pas"/> + <Caret Line="861" TopLine="836"/> + </Position9> + <Position10> + <Filename Value="..\..\fpsutils.pas"/> + <Caret Line="863" TopLine="836"/> + </Position10> + <Position11> + <Filename Value="..\..\fpsutils.pas"/> + <Caret Line="864" TopLine="836"/> + </Position11> + <Position12> + <Filename Value="..\..\fpsutils.pas"/> + <Caret Line="865" TopLine="836"/> + </Position12> + <Position13> + <Filename Value="..\..\fpsutils.pas"/> + <Caret Line="867" TopLine="837"/> + </Position13> + <Position14> + <Filename Value="..\..\fpsutils.pas"/> + <Caret Line="875" TopLine="857"/> + </Position14> + <Position15> + <Filename Value="..\..\fpsutils.pas"/> + <Caret Line="876" TopLine="857"/> + </Position15> + <Position16> + <Filename Value="..\..\fpsutils.pas"/> + <Caret Line="879" TopLine="857"/> + </Position16> + <Position17> + <Filename Value="..\..\fpsutils.pas"/> + <Caret Line="876" TopLine="857"/> + </Position17> + <Position18> + <Filename Value="..\..\fpsutils.pas"/> + <Caret Line="879" TopLine="857"/> + </Position18> + <Position19> + <Filename Value="..\..\fpsutils.pas"/> + <Caret Line="877" TopLine="857"/> + </Position19> + <Position20> + <Filename Value="..\..\fpsutils.pas"/> + <Caret Line="879" TopLine="857"/> + </Position20> + <Position21> + <Filename Value="..\..\fpsutils.pas"/> + <Caret Line="878" TopLine="857"/> + </Position21> + <Position22> + <Filename Value="..\..\fpsutils.pas"/> + <Caret Line="879" TopLine="857"/> + </Position22> + <Position23> + <Filename Value="..\..\fpsutils.pas"/> + <Caret Line="878" TopLine="857"/> + </Position23> + <Position24> + <Filename Value="..\..\fpsutils.pas"/> + <Caret Line="879" TopLine="857"/> + </Position24> + <Position25> + <Filename Value="..\..\fpsutils.pas"/> + <Caret Line="876" TopLine="857"/> + </Position25> + <Position26> + <Filename Value="..\..\fpsutils.pas"/> + <Caret Line="879" TopLine="857"/> + </Position26> + <Position27> + <Filename Value="..\..\fpsutils.pas"/> + <Caret Line="894" TopLine="876"/> + </Position27> + <Position28> + <Filename Value="..\..\fpspreadsheet.pas"/> + <Caret Line="2997" TopLine="2966"/> + </Position28> + <Position29> + <Filename Value="..\..\fpspreadsheet.pas"/> + <Caret Line="2998" TopLine="2967"/> + </Position29> + <Position30> + <Filename Value="..\..\fpspreadsheet.pas"/> + <Caret Line="2961" TopLine="2942"/> + </Position30> + </JumpHistory> + </ProjectSession> +</CONFIG> diff --git a/components/fpspreadsheet/examples/other/test_formula_func.pas b/components/fpspreadsheet/examples/other/test_formula_func.pas new file mode 100644 index 000000000..357973240 --- /dev/null +++ b/components/fpspreadsheet/examples/other/test_formula_func.pas @@ -0,0 +1,126 @@ +{ This demo show how a user-provided function can be used for calculation of + rpn formulas that are built-in to fpspreadsheet, but don't have an own + calculation procedure. } + +program test_formula_func; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Classes, laz_fpspreadsheet + { you can add units after this }, + math, fpspreadsheet, fpsfunc; + +const + paymentAtEnd = 0; + paymentAtBegin = 1; + +{ Calculates the future value of an investment based on an interest rate and + a constant payment schedule: + - "interest_rate" is the interest rate for the investment (as decimal, not percent) + - "number_periods" is the number of payment periods, i.e. number of payments + for the annuity. + - "payment" is the amount of the payment made each period + - "PV" is the present value of the payments. + - "payment_type" indicates when the payments are due (see paymentAtXXX constants) + see: http://en.wikipedia.org/wiki/Future_value +} +function FV(interest_rate, number_periods, payment, pv: Double; + payment_type: integer): Double; +var + q: Double; +begin + q := 1.0 + interest_rate; + + Result := pv * power(q, number_periods) + + (power(q, number_periods) - 1) / (q - 1) * payment; + + if payment_type = paymentAtBegin then + Result := Result * q; +end; + +function fpsFV(Args: TsArgumentStack; NumArgs: Integer): TsArgument; +var + arg_interestRate, arg_numberPayments, arg_Payment, arg_PV, arg_paymentType: TsArgument; +begin + // Pop the argument off the stack. + // Note: they come off in the reverse order they were pushed! + arg_paymentType := Args.Pop; + arg_PV := Args.Pop; + arg_Payment := Args.Pop; + arg_numberPayments := Args.Pop; + arg_interestRate := Args.Pop; + + // Call our FV function with the NumberValues of the arguments. + Result := CreateNumber(FV( + arg_interestRate.NumberValue, + arg_numberPayments.NumberValue, + arg_Payment.NumberValue, + arg_PV.NumberValue, + round(arg_paymentType.NumberValue) + )); +end; + +const + INTEREST_RATE = 0.03; + NUMBER_PAYMENTS = 10; + PAYMENT = 1000; + PRESENT_VALUE = 10000; + PAYMENT_WHEN = paymentAtEnd; + +var + workbook: TsWorkbook; + worksheet: TsWorksheet; + +begin + RegisterFormulaFunc(fekFV, @fpsFV); + + workbook := TsWorkbook.Create; + try + worksheet := workbook.AddWorksheet('Financial'); + worksheet.Options := worksheet.Options + [soCalcBeforeSaving]; + worksheet.WriteColWidth(0, 20); + + worksheet.WriteUTF8Text(0, 0, 'Interest rate'); + worksheet.WriteNumber(0, 1, INTEREST_RATE, nfPercentage, 1); + + worksheet.WriteUTF8Text(1, 0, 'Number of payments'); + worksheet.WriteNumber(1, 1, NUMBER_PAYMENTS); + + worksheet.WriteUTF8Text(2, 0, 'Payment'); + worksheet.WriteCurrency(2, 1, PAYMENT, nfCurrency, 2, '$'); + + worksheet.WriteUTF8Text(3, 0, 'Present value'); + worksheet.WriteCurrency(3, 1, PRESENT_VALUE, nfCurrency, 2, '$'); + + worksheet.WriteUTF8Text(4, 0, 'Payment at end'); + worksheet.WriteBoolValue(4, 1, PAYMENT_WHEN = paymentAtEnd); + + worksheet.WriteUTF8Text(6, 0, 'Future value'); + worksheet.WriteFontStyle(6, 0, [fssBold]); + worksheet.WriteUTF8Text(7, 0, 'Our calculation'); + worksheet.WriteCurrency(7, 1, + FV(INTEREST_RATE, NUMBER_PAYMENTS, PAYMENT, PRESENT_VALUE, PAYMENT_WHEN), + nfCurrency, 2, '$' + ); + + worksheet.WriteUTF8Text(8, 0, 'Excel''s calculation'); + worksheet.WriteNumberFormat(8, 1, nfCurrency, 2, '$'); + worksheet.WriteRPNFormula(8, 1, CreateRPNFormula( + RPNNumber(INTEREST_RATE, + RPNNumber(NUMBER_PAYMENTS, + RPNNumber(-PAYMENT, + RPNNumber(-PRESENT_VALUE, + RPNNumber(PAYMENT_WHEN, + RPNFunc(fekFV, 5, + nil)))))))); + + workbook.WriteToFile('test_fv.xls', sfExcel8, true); + finally + workbook.Free; + end; +end. + diff --git a/components/fpspreadsheet/fpsfunc.pas b/components/fpspreadsheet/fpsfunc.pas index 7219c5e54..7661d9c99 100644 --- a/components/fpspreadsheet/fpsfunc.pas +++ b/components/fpspreadsheet/fpsfunc.pas @@ -145,6 +145,7 @@ function fpsISNUMBER (Args: TsArgumentStack; NumArgs: Integer): TsArgument; function fpsISTEXT (Args: TsArgumentStack; NumArgs: Integer): TsArgument; function fpsVALUE (Args: TsArgumentStack; NumArgs: Integer): TsArgument; + implementation uses diff --git a/components/fpspreadsheet/fpspreadsheet.pas b/components/fpspreadsheet/fpspreadsheet.pas index 3ab0ef7c6..ee60abf4c 100755 --- a/components/fpspreadsheet/fpspreadsheet.pas +++ b/components/fpspreadsheet/fpspreadsheet.pas @@ -589,6 +589,12 @@ type const AFormatString: String = ''); overload; procedure WriteNumberFormat(ACell: PCell; ANumberFormat: TsNumberFormat; const AFormatString: String = ''); overload; + procedure WriteNumberFormat(ARow, ACol: Cardinal; ANumberFormat: TsNumberFormat; + ADecimals: Integer; ACurrencySymbol: String = ''; APosCurrFormat: Integer = -1; + ANegCurrFormat: Integer = -1); overload; + procedure WriteNumberFormat(ACell: PCell; ANumberFormat: TsNumberFormat; + ADecimals: Integer; ACurrencySymbol: String = ''; + APosCurrFormat: Integer = -1; ANegCurrFormat: Integer = -1); overload; procedure WriteTextRotation(ARow, ACol: Cardinal; ARotation: TsTextRotation); @@ -983,10 +989,10 @@ type var GsSpreadFormats: array of TsSpreadFormatData; -procedure RegisterSpreadFormat( - AReaderClass: TsSpreadReaderClass; - AWriterClass: TsSpreadWriterClass; - AFormat: TsSpreadsheetFormat); +procedure RegisterFormulaFunc(AFormulaKind: TFEKind; AFunc: pointer); + +procedure RegisterSpreadFormat( AReaderClass: TsSpreadReaderClass; + AWriterClass: TsSpreadWriterClass; AFormat: TsSpreadsheetFormat); procedure CopyCellFormat(AFromCell, AToCell: PCell); function GetFileFormatName(AFormat: TsSpreadsheetFormat): String; @@ -1096,7 +1102,7 @@ type Func: TsFormulaFunc; end; -const +var FEProps: array[TFEKind] of TFEProp = ( // functions marked by (*) { Operands } // are only partially supported (Symbol:''; MinParams:Byte(-1); MaxParams:Byte(-1); Func:nil), // fekCell @@ -1238,6 +1244,22 @@ const (Symbol:'SUM'; MinParams:1; MaxParams:1; Func:nil) // fekOpSUM (Unary sum operation). Note: CANNOT be used for summing sell contents; use fekSUM} ); +{@@ + Registers a function used when calculating a formula. + This feature allows to extend the built-in functions directly available in + fpspreadsheet. + + @param AFormulaKind Identifier of the formula element + @param AFunc Function to be executed when the identifier is met + in an rpn formula. The function declaration MUST + follow the structure given by TsFormulaFunc. +} +procedure RegisterFormulaFunc(AFormulaKind: TFEKind; AFunc: Pointer); +begin + FEProps[AFormulaKind].Func := TsFormulaFunc(AFunc); +end; + + {@@ Registers a new reader/writer pair for a given spreadsheet file format } @@ -2914,6 +2936,67 @@ begin ChangedCell(ARow, ACol); end; +{@@ + Adds a number format to the formatting of a cell + + @param ARow The row of the cell + @param ACol The column of the cell + @param ANumberFormat Identifier of the format to be applied + @param ADecimals Number of decimal places + @param ACurrencySymbol optional currency symbol in case of nfCurrency + @param APosCurrFormat optional identifier for positive currencies + @param ANegCurrFormat optional identifier for negative currencies + + @see TsNumberFormat +} +procedure TsWorksheet.WriteNumberFormat(ARow, ACol: Cardinal; + ANumberFormat: TsNumberFormat; ADecimals: Integer; ACurrencySymbol: String = ''; + APosCurrFormat: Integer = -1; ANegCurrFormat: Integer = -1); +var + ACell: PCell; +begin + ACell := GetCell(ARow, ACol); + WriteNumberFormat(ACell, ANumberFormat, ADecimals, ACurrencySymbol, + APosCurrFormat, ANegCurrFormat); +end; + +{@@ + Adds a number format to the formatting of a cell + + @param ARow The row of the cell + @param ACol The column of the cell + @param ANumberFormat Identifier of the format to be applied + @param ADecimals Number of decimal places + @param ACurrencySymbol optional currency symbol in case of nfCurrency + @param APosCurrFormat optional identifier for positive currencies + @param ANegCurrFormat optional identifier for negative currencies + + @see TsNumberFormat +} +procedure TsWorksheet.WriteNumberFormat(ACell: PCell; + ANumberFormat: TsNumberFormat; ADecimals: Integer; ACurrencySymbol: String = ''; + APosCurrFormat: Integer = -1; ANegCurrFormat: Integer = -1); +begin + if ACell = nil then + exit; + + ACell^.NumberFormat := ANumberFormat; + if ANumberFormat <> nfGeneral then begin + Include(ACell^.UsedFormattingFields, uffNumberFormat); + if ANumberFormat in [nfCurrency, nfCurrencyRed] then + ACell^.NumberFormatStr := BuildCurrencyFormatString(nfdDefault, ANumberFormat, + Workbook.FormatSettings, ADecimals, + APosCurrFormat, ANegCurrFormat, ACurrencySymbol) + else + ACell^.NumberFormatStr := BuildNumberFormatString(ANumberFormat, + Workbook.FormatSettings, ADecimals); + end else begin + Exclude(ACell^.UsedFormattingFields, uffNumberFormat); + ACell^.NumberFormatStr := ''; + end; + ChangedCell(ACell^.Row, ACell^.Col); +end; + {@@ Adds number format to the formatting of a cell