{ Utility functions and constants from FPSpreadsheet } // to do: Remove the patched FormatDateTime when the feature of square brackets // in time format codes is in the rtl unit fpsutils; {$mode objfpc}{$H+} interface uses Classes, SysUtils, StrUtils, fpspreadsheet, fpsNumFormatParser; // Exported types type {@@ Selection direction along column or along row } TsSelectionDirection = (fpsVerticalSelection, fpsHorizontalSelection); {@@ Set of characters } TsDecsChars = set of char; {@@ Options for the FormatDateTime function to activate time interval strings with more than 24 hours. Will be removed when this feature is in the stable release of FPC } TFormatDateTimeOption = (fdoInterval); {@@ Options for the FormatDateTime function to activate time interval strings with more than 24 hours. Will be removed when this feature is in the stable release of FPC } TFormatDateTimeOptions = set of TFormatDateTimeOption; const {@@ Date formatting string for unambiguous date/time display as strings Can be used for text output when date/time cell support is not available } ISO8601Format='yyyymmdd"T"hhmmss'; {@@ Extended ISO 8601 date/time format, used in e.g. ODF/opendocument } ISO8601FormatExtended='yyyy"-"mm"-"dd"T"hh":"mm":"ss'; {@@ ISO 8601 date-only format, used in ODF/opendocument } ISO8601FormatDateOnly='yyyy"-"mm"-"dd'; {@@ ISO 8601 time-only format, used in ODF/opendocument } ISO8601FormatTimeOnly='"PT"hh"H"nn"M"ss"S"'; {@@ ISO 8601 time-only format, with hours overflow } ISO8601FormatHoursOverflow='"PT"[hh]"H"nn"M"ss.zz"S"'; // Endianess helper functions function WordToLE(AValue: Word): Word; function DWordToLE(AValue: Cardinal): Cardinal; function IntegerToLE(AValue: Integer): Integer; function WideStringToLE(const AValue: WideString): WideString; function WordLEtoN(AValue: Word): Word; function DWordLEtoN(AValue: Cardinal): Cardinal; function WideStringLEToN(const AValue: WideString): WideString; function LongRGBToExcelPhysical(const RGB: DWord): DWord; // Other routines function ParseIntervalString(const AStr: string; out AFirstCellRow, AFirstCellCol, ACount: Cardinal; out ADirection: TsSelectionDirection): Boolean; function ParseCellRangeString(const AStr: string; out AFirstCellRow, AFirstCellCol, ALastCellRow, ALastCellCol: Cardinal; out AFlags: TsRelFlags): Boolean; overload; function ParseCellRangeString(const AStr: string; out AFirstCellRow, AFirstCellCol, ALastCellRow, ALastCellCol: Cardinal): Boolean; overload; function ParseCellString(const AStr: string; out ACellRow, ACellCol: Cardinal; out AFlags: TsRelFlags): Boolean; overload; function ParseCellString(const AStr: string; out ACellRow, ACellCol: Cardinal): Boolean; overload; function ParseCellRowString(const AStr: string; out AResult: Cardinal): Boolean; function ParseCellColString(const AStr: string; out AResult: Cardinal): Boolean; function GetColString(AColIndex: Integer): String; function GetCellString(ARow,ACol: Cardinal; AFlags: TsRelFlags = [rfRelRow, rfRelCol]): String; function GetCellRangeString(ARow1, ACol1, ARow2, ACol2: Cardinal; AFlags: TsRelFlags = [rfRelRow, rfRelCol, rfRelRow2, rfRelCol2]): String; function GetErrorValueStr(AErrorValue: TsErrorValue): String; function IfThen(ACondition: Boolean; AValue1,AValue2: TsNumberFormat): TsNumberFormat; overload; function IsCurrencyFormat(AFormat: TsNumberFormat): Boolean; function IsDateTimeFormat(AFormat: TsNumberFormat): Boolean; overload; function IsDateTimeFormat(AFormatStr: String): Boolean; overload; function IsTimeFormat(AFormat: TsNumberFormat): Boolean; overload; function IsTimeFormat(AFormatStr: String): Boolean; overload; function BuildCurrencyFormatString(ADialect: TsNumFormatDialect; ANumberFormat: TsNumberFormat; const AFormatSettings: TFormatSettings; ADecimals, APosCurrFormat, ANegCurrFormat: Integer; ACurrencySymbol: String): String; function BuildDateTimeFormatString(ANumberFormat: TsNumberFormat; const AFormatSettings: TFormatSettings; AFormatString: String = ''): String; function BuildNumberFormatString(ANumberFormat: TsNumberFormat; const AFormatSettings: TFormatSettings; ADecimals: Integer = -1): String; function AddAMPM(const ATimeFormatString: String; const AFormatSettings: TFormatSettings): String; function StripAMPM(const ATimeFormatString: String): String; function CountDecs(AFormatString: String; ADecChars: TsDecsChars = ['0']): Byte; function AddIntervalBrackets(AFormatString: String): String; function MakeLongDateFormat(ADateFormat: String): String; function MakeShortDateFormat(ADateFormat: String): String; function SpecialDateTimeFormat(ACode: String; const AFormatSettings: TFormatSettings; ForWriting: Boolean): String; procedure SplitFormatString(const AFormatString: String; out APositivePart, ANegativePart, AZeroPart: String); procedure MakeTimeIntervalMask(Src: String; var Dest: String); // These two functions are copies of fpc trunk until they are available in stable fpc. function FormatDateTime(const FormatStr: string; DateTime: TDateTime; Options : TFormatDateTimeOptions = []): string; function FormatDateTime(const FormatStr: string; DateTime: TDateTime; const FormatSettings: TFormatSettings; Options : TFormatDateTimeOptions = []): string; function TwipsToPts(AValue: Integer): Single; function PtsToTwips(AValue: Single): Integer; function cmToPts(AValue: Double): Double; function PtsToCm(AValue: Double): Double; function InToPts(AValue: Double): Double; function mmToPts(AValue: Double): Double; function PtsToMM(AValue: Double): Double; function pxToPts(AValue, AScreenPixelsPerInch: Integer): Double; function PtsToPx(AValue: Double; AScreenPixelsPerInch: Integer): Integer; function HTMLLengthStrToPts(AValue: String): Double; function HTMLColorStrToColor(AValue: String): TsColorValue; function ColorToHTMLColorStr(AValue: TsColorValue; AExcelDialect: Boolean = false): String; function UTF8TextToXMLText(AText: ansistring): ansistring; function TintedColor(AColor: TsColorValue; tint: Double): TsColorValue; function AnalyzeCompareStr(AString: String; out ACompareOp: TsCompareOperation): String; procedure AppendToStream(AStream: TStream; const AString: String); inline; overload; procedure AppendToStream(AStream: TStream; const AString1, AString2: String); inline; overload; procedure AppendToStream(AStream: TStream; const AString1, AString2, AString3: String); inline; overload; function PosInMemory(AMagic: QWord; ABuffer: PByteArray; ABufSize: Integer): Integer; procedure Unused(const A1); procedure Unused(const A1, A2); procedure Unused(const A1, A2, A3); { For debugging purposes } procedure DumpFontsToFile(AWorkbook: TsWorkbook; AFileName: String); var ScreenPixelsPerInch: Integer = 96; implementation uses Math, lazutf8; type TRGBA = record r, g, b, a: byte end; {******************************************************************************} { Endianess helper functions } {******************************************************************************} { Excel files are all written with little endian byte order, so it's necessary to swap the data to be able to build a correct file on big endian systems. The routines WordToLE, DWordToLE, IntegerToLE etc are preferable to System unit routines because they ensure that the correct overloaded version of the conversion routines will be used, avoiding typecasts which are less readable. They also guarantee delphi compatibility. For Delphi we just support big-endian isn't support, because Delphi doesn't support it. } {@@ WordLEToLE converts a word value from big-endian to little-endian byte order. @param AValue Big-endian word value @return Little-endian word value } function WordToLE(AValue: Word): Word; begin {$IFDEF FPC} Result := NtoLE(AValue); {$ELSE} Result := AValue; {$ENDIF} end; {@@ DWordLEToLE converts a DWord value from big-endian to little-endian byte-order. @param AValue Big-endian DWord value @return Little-endian DWord value } function DWordToLE(AValue: Cardinal): Cardinal; begin {$IFDEF FPC} Result := NtoLE(AValue); {$ELSE} Result := AValue; {$ENDIF} end; {@@ Converts an integer value from big-endian to little-endian byte-order. @param AValue Big-endian integer value @return Little-endian integer value } function IntegerToLE(AValue: Integer): Integer; begin {$IFDEF FPC} Result := NtoLE(AValue); {$ELSE} Result := AValue; {$ENDIF} end; {@@ Converts a word value from little-endian to big-endian byte-order. @param AValue Little-endian word value @return Big-endian word value } function WordLEtoN(AValue: Word): Word; begin {$IFDEF FPC} Result := LEtoN(AValue); {$ELSE} Result := AValue; {$ENDIF} end; {@@ Converts a DWord value from little-endian to big-endian byte-order. @param AValue Little-endian DWord value @return Big-endian DWord value } function DWordLEtoN(AValue: Cardinal): Cardinal; begin {$IFDEF FPC} Result := LEtoN(AValue); {$ELSE} Result := AValue; {$ENDIF} end; {@@ Converts a widestring from big-endian to little-endian byte-order. @param AValue Big-endian widestring @return Little-endian widestring } function WideStringToLE(const AValue: WideString): WideString; {$IFNDEF FPC} var j: integer; {$ENDIF} begin {$IFDEF FPC} {$IFDEF FPC_LITTLE_ENDIAN} Result:=AValue; {$ELSE} Result:=AValue; for j := 1 to Length(AValue) do begin PWORD(@Result[j])^:=NToLE(PWORD(@Result[j])^); end; {$ENDIF} {$ELSE} Result:=AValue; {$ENDIF} end; {@@ Converts a widestring from little-endian to big-endian byte-order. @param AValue Little-endian widestring @return Big-endian widestring } function WideStringLEToN(const AValue: WideString): WideString; {$IFNDEF FPC} var j: integer; {$ENDIF} begin {$IFDEF FPC} {$IFDEF FPC_LITTLE_ENDIAN} Result:=AValue; {$ELSE} Result:=AValue; for j := 1 to Length(AValue) do begin PWORD(@Result[j])^:=LEToN(PWORD(@Result[j])^); end; {$ENDIF} {$ELSE} Result:=AValue; {$ENDIF} end; {@@ Converts the RGB part of a LongRGB logical structure to its physical representation. In other words: RGBA (where A is 0 and omitted in the function call) => ABGR Needed for conversion of palette colors. @param RGB DWord value containing RGBA bytes in big endian byte-order @return DWord containing RGB bytes in little-endian byte-order (A = 0) } function LongRGBToExcelPhysical(const RGB: DWord): DWord; begin {$IFDEF FPC} {$IFDEF ENDIAN_LITTLE} result := RGB shl 8; //tags $00 at end for the A byte result := SwapEndian(result); //flip byte order {$ELSE} //Big endian result := RGB; //leave value as is //todo: verify if this turns out ok {$ENDIF} {$ELSE} // messed up result {$ENDIF} end; {@@ Parses strings like A5:A10 into an selection interval information @param AStr Cell range string, such as A5:A10 @param AFirstCellRow Row index of the first cell of the range (output) @param AFirstCellCol Column index of the first cell of the range (output) @param ACount Number of cells included in the range (output) @param ADirection fpsVerticalSelection if the range is along a column, fpsHorizontalSelection if the range is along a row @return false if the string is not a valid cell range } function ParseIntervalString(const AStr: string; out AFirstCellRow, AFirstCellCol, ACount: Cardinal; out ADirection: TsSelectionDirection): Boolean; var //Cells: TStringList; LastCellRow, LastCellCol: Cardinal; p: Integer; s1, s2: String; begin Result := True; { Simpler: use "pos" instead of the TStringList overhead. And: the StringList is not free'ed here // First get the cells Cells := TStringList.Create; ExtractStrings([':'],[], PChar(AStr), Cells); // Then parse each of them Result := ParseCellString(Cells[0], AFirstCellRow, AFirstCellCol); if not Result then Exit; Result := ParseCellString(Cells[1], LastCellRow, LastCellCol); if not Result then Exit; } // First find the position of the colon and split into parts p := pos(':', AStr); if p = 0 then exit(false); s1 := copy(AStr, 1, p-1); s2 := copy(AStr, p+1, Length(AStr)); // Then parse each of them Result := ParseCellString(s1, AFirstCellRow, AFirstCellCol); if not Result then Exit; Result := ParseCellString(s2, LastCellRow, LastCellCol); if not Result then Exit; if AFirstCellRow = LastCellRow then begin ADirection := fpsHorizontalSelection; ACount := LastCellCol - AFirstCellCol + 1; end else if AFirstCellCol = LastCellCol then begin ADirection := fpsVerticalSelection; ACount := LastCellRow - AFirstCellRow + 1; end else Exit(False); end; {@@ Parses strings like A5:C10 into a range selection information. Returns in AFlags also information on relative/absolute cells. @param AStr Cell range string, such as A5:C10 @param AFirstCellRow Row index of the top/left cell of the range (output) @param AFirstCellCol Column index of the top/left cell of the range (output) @param ALastCellRow Row index of the bottom/right cell of the range (output) @param ALastCellCol Column index of the bottom/right cell of the range (output) @param AFlags a set containing an element for AFirstCellRow, AFirstCellCol, ALastCellRow, ALastCellCol if they represent relative cell addresses. @return false if the string is not a valid cell range } function ParseCellRangeString(const AStr: string; out AFirstCellRow, AFirstCellCol, ALastCellRow, ALastCellCol: Cardinal; out AFlags: TsRelFlags): Boolean; var p: Integer; s: String; f: TsRelFlags; begin Result := True; // First find the colon p := pos(':', AStr); if p = 0 then exit(false); // Analyze part after the colon s := copy(AStr, p+1, Length(AStr)); Result := ParseCellString(s, ALastCellRow, ALastCellCol, f); if not Result then exit; // Analyze part before the colon s := copy(AStr, 1, p-1); Result := ParseCellString(s, AFirstCellRow, AFirstCellCol, AFlags); // Add flags of 2nd part if rfRelRow in f then Include(AFlags, rfRelRow2); if rfRelCol in f then Include(AFlags, rfRelCol2); end; {@@ Parses strings like A5:C10 into a range selection information. Information on relative/absolute cells is ignored. @param AStr Cell range string, such as A5:C10 @param AFirstCellRow Row index of the top/left cell of the range (output) @param AFirstCellCol Column index of the top/left cell of the range (output) @param ALastCellRow Row index of the bottom/right cell of the range (output) @param ALastCellCol Column index of the bottom/right cell of the range (output) @return false if the string is not a valid cell range } function ParseCellRangeString(const AStr: string; out AFirstCellRow, AFirstCellCol, ALastCellRow, ALastCellCol: Cardinal): Boolean; var flags: TsRelFlags; begin Result := ParseCellRangeString(AStr, AFirstCellRow, AFirstCellCol, ALastCellRow, ALastCellCol, flags); end; {@@ Parses a cell string, like 'A1' into zero-based column and row numbers Note that there can be several letters to address for more than 26 columns. 'AFlags' indicates relative addresses. @param AStr Cell range string, such as A1 @param ACellRow Row index of the top/left cell of the range (output) @param ACellCol Column index of the top/left cell of the range (output) @param AFlags A set containing an element for ACellRow and/or ACellCol, if they represent a relative cell address. @return False if the string is not a valid cell range @example "AMP$200" --> (rel) column 1029 (= 26*26*1 + 26*16 + 26 - 1) (abs) row = 199 (abs) } function ParseCellString(const AStr: String; out ACellRow, ACellCol: Cardinal; out AFlags: TsRelFlags): Boolean; function Scan(AStartPos: Integer): Boolean; const LETTERS = ['A'..'Z']; DIGITS = ['0'..'9']; var i: Integer; isAbs: Boolean; begin Result := false; i := AStartPos; // Scan letters while (i <= Length(AStr)) do begin if (UpCase(AStr[i]) in LETTERS) then begin ACellCol := Cardinal(ord(UpCase(AStr[i])) - ord('A')) + 1 + ACellCol * 26; if ACellCol >= MAX_COL_COUNT then // too many columns (dropping this limitation could cause overflow if a too long string is passed exit; inc(i); end else if (AStr[i] in DIGITS) or (AStr[i] = '$') then break else begin ACellCol := 0; exit; // Only letters or $ allowed end; end; if AStartPos = 1 then Include(AFlags, rfRelCol); isAbs := (AStr[i] = '$'); if isAbs then inc(i); if i > Length(AStr) then exit; // Scan digits while (i <= Length(AStr)) do begin if (AStr[i] in DIGITS) then begin ACellRow := Cardinal(ord(AStr[i]) - ord('0')) + ACellRow * 10; inc(i); end else begin ACellCol := 0; ACellRow := 0; AFlags := []; exit; end; end; dec(ACellCol); dec(ACellRow); if not isAbs then Include(AFlags, rfRelRow); Result := true; end; begin ACellCol := 0; ACellRow := 0; AFlags := []; if AStr = '' then Exit(false); if (AStr[1] = '$') then Result := Scan(2) else Result := Scan(1); end; {@@ Parses a cell string, like 'A1' into zero-based column and row numbers Note that there can be several letters to address for more than 26 columns. For compatibility with old version which does not return flags for relative cell addresses. @param AStr Cell range string, such as A1 @param ACellRow Row index of the top/left cell of the range (output) @param ACellCol Column index of the top/left cell of the range (output) @return False if the string is not a valid cell range } function ParseCellString(const AStr: string; out ACellRow, ACellCol: Cardinal): Boolean; var flags: TsRelFlags; begin Result := ParseCellString(AStr, ACellRow, ACellCol, flags); end; {@@ Parses a cell row string to a zero-based row number. @param AStr Cell row string, such as '1', 1-based! @param AResult Index of the row (zero-based!) (putput) @return False if the string is not a valid cell row string } function ParseCellRowString(const AStr: string; out AResult: Cardinal): Boolean; begin try AResult := StrToInt(AStr) - 1; except Result := False; end; Result := True; end; {@@ Parses a cell column string, like 'A' or 'CZ', into a zero-based column number. Note that there can be several letters to address more than 26 columns. @param AStr Cell range string, such as A1 @param AResult Zero-based index of the column (output) @return False if the string is not a valid cell column string } function ParseCellColString(const AStr: string; out AResult: Cardinal): Boolean; const INT_NUM_LETTERS = 26; begin Result := False; AResult := 0; if Length(AStr) = 1 then AResult := Ord(AStr[1]) - Ord('A') else if Length(AStr) = 2 then begin AResult := (Ord(AStr[1]) - Ord('A') + 1) * INT_NUM_LETTERS + Ord(AStr[2]) - Ord('A'); end else if Length(AStr) = 3 then begin AResult := (Ord(AStr[1]) - Ord('A') + 1) * INT_NUM_LETTERS * INT_NUM_LETTERS + (Ord(AStr[2]) - Ord('A') + 1) * INT_NUM_LETTERS + Ord(AStr[3]) - Ord('A'); end else Exit(False); Result := True; end; function Letter(AValue: Integer): char; begin Result := Char(AValue + ord('A')); end; {@@ Calculates an Excel column name ('A', 'B' etc) from the zero-based column index @param AColIndex Zero-based column index @return Letter-based column name string. Can contain several letter in case of more than 26 columns } function GetColString(AColIndex: Integer): String; { Code adapted from: http://stackoverflow.com/questions/12796973/vba-function-to-convert-column-number-to-letter } var n: Integer; c: byte; begin Result := ''; n := AColIndex + 1; while (n > 0) do begin c := (n - 1) mod 26; Result := char(c + ord('A')) + Result; n := (n - c) div 26; end; end; const RELCHAR: Array[boolean] of String = ('$', ''); {@@ Calculates a cell address string from zero-based column and row indexes and the relative address state flags. @param ARowIndex Zero-based row index @param AColIndex Zero-based column index @param AFlags An optional set containing an entry for column and row if these addresses are relative. By default, relative addresses are assumed. @return Excel type of cell address containing $ characters for absolute address parts. @example ARowIndex = 0, AColIndex = 0, AFlags = [rfRelRow] --> $A1 } function GetCellString(ARow, ACol: Cardinal; AFlags: TsRelFlags = [rfRelRow, rfRelCol]): String; begin Result := Format('%s%s%s%d', [ RELCHAR[rfRelCol in AFlags], GetColString(ACol), RELCHAR[rfRelRow in AFlags], ARow+1 ]); end; {@@ Calculates a cell range address string from zero-based column and row indexes and the relative address state flags. @param ARow1 Zero-based index of the first row in the range @param ACol1 Zero-based index of the first column in the range @param ARow2 Zero-based index of the last row in the range @param ACol2 Zero-based index of the last column in the range @param AFlags A set containing an entry for first and last column and row if their addresses are relative. @return Excel type of cell address range containing '$' characters for absolute address parts and a ':' to separate the first and last cells of the range @example ARow1 = 0, ACol1 = 0, ARow = 2, ACol = 1, AFlags = [rfRelRow, rfRelRow2] --> $A1:$B3 } function GetCellRangeString(ARow1, ACol1, ARow2, ACol2: Cardinal; AFlags: TsRelFlags = [rfRelRow, rfRelCol, rfRelRow2, rfRelCol2]): String; begin Result := Format('%s%s%s%d:%s%s%s%d', [ RELCHAR[rfRelCol in AFlags], GetColString(ACol1), RELCHAR[rfRelRow in AFlags], ARow1 + 1, RELCHAR[rfRelCol2 in AFlags], GetColString(ACol2), RELCHAR[rfRelRow2 in AFlags], ARow2 + 1 ]); end; {@@ Returns the message text assigned to an error value @param AErrorValue Error code as defined by TsErrorvalue @return Text corresponding to the error code. } function GetErrorValueStr(AErrorValue: TsErrorValue): String; begin case AErrorValue of errOK : Result := ''; errEmptyIntersection : Result := '#NULL!'; errDivideByZero : Result := '#DIV/0!'; errWrongType : Result := '#VALUE!'; errIllegalRef : Result := '#REF!'; errWrongName : Result := '#NAME?'; errOverflow : Result := '#NUM!'; errArgError : Result := '#N/A'; // --- no Excel errors -- errFormulaNotSupported : Result := '#FORMULA?'; else Result := '#UNKNOWN ERROR'; end; end; {@@ Helper function to reduce typing: "if a conditions is true return the first number format, otherwise return the second format" @param ACondition Boolean expression @param AValue1 First built-in number format code @param AValue2 Second built-in number format code @return AValue1 if ACondition is true, AValue2 otherwise. } function IfThen(ACondition: Boolean; AValue1, AValue2: TsNumberFormat): TsNumberFormat; begin if ACondition then Result := AValue1 else Result := AValue2; end; {@@ Checks whether the given number format code is for currency, i.e. requires currency symbol. @param AFormat Built-in number format identifier to be checked @return True if AFormat is nfCurrency or nfCurrencyRed, false otherwise. } function IsCurrencyFormat(AFormat: TsNumberFormat): Boolean; begin Result := AFormat in [nfCurrency, nfCurrencyRed]; end; {@@ Checks whether the given number format code is for date/time values. @param AFormat Built-in number format identifier to be checked @return True if AFormat is a date/time format (such as nfShortTime), false otherwise } function IsDateTimeFormat(AFormat: TsNumberFormat): Boolean; begin Result := AFormat in [{nfFmtDateTime, }nfShortDateTime, nfShortDate, nfLongDate, nfShortTime, nfLongTime, nfShortTimeAM, nfLongTimeAM, nfTimeInterval]; end; {@@ Checks whether the given string with formatting codes is for date/time values. @param AFormatStr String with formatting codes to be checked. @return True if AFormatStr is a date/time format string (such as 'hh:nn'), false otherwise } function IsDateTimeFormat(AFormatStr: string): Boolean; var parser: TsNumFormatParser; begin parser := TsNumFormatParser.Create(nil, AFormatStr); try Result := parser.IsDateTimeFormat; finally parser.Free; end; end; {@@ Checks whether the given built-in number format code is for time values. @param AFormat Built-in number format identifier to be checked @return True if AFormat represents to a time-format, false otherwise } function IsTimeFormat(AFormat: TsNumberFormat): boolean; begin Result := AFormat in [nfShortTime, nfLongTime, nfShortTimeAM, nfLongTimeAM, nfTimeInterval]; end; {@@ Checks whether the given string with formatting codes is for time values. @param AFormatStr String with formatting codes to be checked @return True if AFormatStr represents a time-format, false otherwise } function IsTimeFormat(AFormatStr: String): Boolean; var parser: TsNumFormatParser; begin parser := TsNumFormatParser.Create(nil, AFormatStr); try Result := parser.IsTimeFormat; finally parser.Free; end; end; {@@ Builds a date/time format string from the number format code. @param ANumberFormat built-in number format identifier @param AFormatSettings Format settings from which locale-dependent information like day-month-year order is taken. @param AFormatString Optional pre-built formatting string. It is used only for the format nfInterval where square brackets are added to the first time code field. @return String of date/time formatting code constructed from the built-in format information. } function BuildDateTimeFormatString(ANumberFormat: TsNumberFormat; const AFormatSettings: TFormatSettings; AFormatString: String = '') : string; begin case ANumberFormat of nfShortDateTime: Result := AFormatSettings.ShortDateFormat + ' ' + AFormatSettings.ShortTimeFormat; // In the DefaultFormatSettings this is: d/m/y hh:nn nfShortDate: Result := AFormatSettings.ShortDateFormat; // --> d/m/y nfLongDate: Result := AFormatSettings.LongDateFormat; // --> dd mm yyyy nfShortTime: Result := StripAMPM(AFormatSettings.ShortTimeFormat); // --> hh:nn nfLongTime: Result := StripAMPM(AFormatSettings.LongTimeFormat); // --> hh:nn:ss nfShortTimeAM: begin // --> hh:nn AM/PM Result := AFormatSettings.ShortTimeFormat; if (pos('a', lowercase(AFormatSettings.ShortTimeFormat)) = 0) then Result := AddAMPM(Result, AFormatSettings); end; nfLongTimeAM: // --> hh:nn:ss AM/PM begin Result := AFormatSettings.LongTimeFormat; if pos('a', lowercase(AFormatSettings.LongTimeFormat)) = 0 then Result := AddAMPM(Result, AFormatSettings); end; nfTimeInterval: // --> [h]:nn:ss if AFormatString = '' then Result := '[h]:mm:ss' else Result := AddIntervalBrackets(AFormatString); end; end; {@@ Builds a currency format string. The presentation of negative values (brackets, or minus signs) is taken from the provided format settings. The format string consists of three sections, separated by semicolons. @param ADialect Determines whether the format string is for use by fpspreadsheet (nfdDefault) or by Excel (nfdExcel) @param ANumberFormat Identifier of the built-in number format for which the format string is to be generated. @param AFormatSettings FormatSettings to be applied (used to extract default values for the next parameters) @param ADecimals number of decimal places. If < 0, the CurrencyDecimals of the FormatSettings is used. @param APosCurrFormat Identifier for the order of currency symbol, value and spaces of positive values - see pcfXXXX constants in fpspreadsheet.pas. If < 0, the CurrencyFormat of the FormatSettings is used. @param ANegCurrFormat Identifier for the order of currency symbol, value and spaces of negative values. Specifies also usage of (). - see ncfXXXX constants in fpspreadsheet.pas. If < 0, the NegCurrFormat of the FormatSettings is used. @param ACurrencySymbol Name of the currency, like $ or USD. If ? the CurrencyString of the FormatSettings is used. @return String of formatting codes, such as '"$"#,##0.00;("$"#,##0.00);"EUR"0.00' } function BuildCurrencyFormatString(ADialect: TsNumFormatDialect; ANumberFormat: TsNumberFormat; const AFormatSettings: TFormatSettings; ADecimals, APosCurrFormat, ANegCurrFormat: Integer; ACurrencySymbol: String): String; const POS_FMT: array[0..3] of string = ( // Format parameter 0 is "value", parameter 1 is "currency symbol" ('"%1:s"%0:s'), // 0: $1 ('%0:s"%1:s"'), // 1: 1$ ('"%1:s" %0:s'), // 2: $ 1 ('%0:s "%1:s"') // 3: 1 $ ); NEG_FMT: array[0..15] of string = ( ('("%1:s"%0:s)'), // 0: ($1) ('-"%1:s"%0:s'), // 1: -$1 ('"%1:s"-%0:s'), // 2: $-1 ('"%1:s"%0:s-'), // 3: $1- ('(%0:s"%1:s")'), // 4: (1$) ('-%0:s"%1:s"'), // 5: -1$ ('%0:s-"%1:s"'), // 6: 1-$ ('%0:s"%1:s"-'), // 7: 1$- ('-%0:s "%1:s"'), // 8: -1 $ ('-"%1:s" %0:s'), // 9: -$ 1 ('%0:s "%1:s"-'), // 10: 1 $- ('"%1:s" %0:s-'), // 11: $ 1- ('"%1:s" -%0:s'), // 12: $ -1 ('%0:s- "%1:s"'), // 13: 1- $ ('("%1:s" %0:s)'), // 14: ($ 1) ('(%0:s "%1:s")') // 15: (1 $) ); var decs: String; pcf, ncf: Byte; p, n: String; negRed: Boolean; begin pcf := IfThen(APosCurrFormat < 0, AFormatSettings.CurrencyFormat, APosCurrFormat); ncf := IfThen(ANegCurrFormat < 0, AFormatSettings.NegCurrFormat, ANegCurrFormat); if (ADecimals < 0) then ADecimals := AFormatSettings.CurrencyDecimals; if ACurrencySymbol = '?' then ACurrencySymbol := AnsiToUTF8(AFormatSettings.CurrencyString); decs := DupeString('0', ADecimals); if ADecimals > 0 then decs := '.' + decs; negRed := (ANumberFormat = nfCurrencyRed); p := POS_FMT[pcf]; // Format mask for positive values n := NEG_FMT[ncf]; // Format mask for negative values // add extra space for the sign of the number for perfect alignment in Excel if ADialect = nfdExcel then case ncf of 0, 14: p := p + '_)'; 3, 11: p := p + '_-'; 4, 15: p := '_(' + p; 5, 8 : p := '_-' + p; end; if ACurrencySymbol <> '' then begin Result := Format(p, ['#,##0' + decs, ACurrencySymbol]) + ';' + IfThen(negRed and (ADialect = nfdExcel), '[red]', '') + Format(n, ['#,##0' + decs, ACurrencySymbol]) + ';' + Format(p, ['0'+decs, ACurrencySymbol]); end else begin Result := '#,##0' + decs; if negRed and (ADialect = nfdExcel) then Result := Result +';[red]' else Result := Result +';'; case ncf of 0, 14, 15 : Result := Result + '(#,##0' + decs + ')'; 1, 2, 5, 6, 8, 9, 12: Result := Result + '-#,##0' + decs; else Result := Result + '#,##0' + decs + '-'; end; Result := Result + ';0' + decs; end; end; {@@ Builds a number format string from the number format code and the count of decimal places. @param ANumberFormat Identifier of the built-in numberformat for which a format string is to be generated @param AFormatSettings FormatSettings for default parameters @param ADecimals Number of decimal places. If < 0 the CurrencyDecimals value of the FormatSettings is used. @return String of formatting codes, such as '#,##0.00' for nfFixedTh and 2 decimals } function BuildNumberFormatString(ANumberFormat: TsNumberFormat; const AFormatSettings: TFormatSettings; ADecimals: Integer = -1): String; var decs: String; begin Result := ''; if ADecimals = -1 then ADecimals := AFormatSettings.CurrencyDecimals; decs := DupeString('0', ADecimals); if ADecimals > 0 then decs := '.' + decs; case ANumberFormat of nfFixed: Result := '0' + decs; nfFixedTh: Result := '#,##0' + decs; nfExp: Result := '0' + decs + 'E+00'; nfPercentage: Result := '0' + decs + '%'; nfCurrency, nfCurrencyRed: raise Exception.Create('BuildNumberFormatString: Use BuildCurrencyFormatString '+ 'to create a format string for currency values.'); nfShortDateTime, nfShortDate, nfLongDate, nfShortTime, nfLongTime, nfShortTimeAM, nfLongTimeAM, nfTimeInterval: raise Exception.Create('BuildNumberFormatString: Use BuildDateTimeFormatSstring '+ 'to create a format string for date/time values.'); end; end; {@@ Adds an AM/PM format code to a pre-built time formatting string. The strings replacing "AM" or "PM" in the final formatted number are taken from the TimeAMString or TimePMString of the given FormatSettings. @param ATimeFormatString String of time formatting codes (such as 'hh:nn') @param AFormatSettings FormatSettings for locale-dependent information @result Formatting string with AM/PM option activated. Example: ATimeFormatString = 'hh:nn' ==> 'hh:nn AM/PM' } function AddAMPM(const ATimeFormatString: String; const AFormatSettings: TFormatSettings): String; var am, pm: String; begin am := IfThen(AFormatSettings.TimeAMString <> '', AFormatSettings.TimeAMString, 'AM'); pm := IfThen(AFormatSettings.TimePMString <> '', AFormatSettings.TimePMString, 'PM'); Result := Format('%s %s/%s', [StripAMPM(ATimeFormatString), am, pm]); end; {@@ Removes an AM/PM formatting code from a given time formatting string. Variants of "AM/PM" are considered as well. The string is left unchanged if it does not contain AM/PM codes. @param ATimeFormatString String of time formatting codes (such as 'hh:nn AM/PM') @return Formatting string with AM/PM being removed (--> 'hh:nn') } function StripAMPM(const ATimeFormatString: String): String; var i: Integer; begin Result := ''; i := 1; while i <= Length(ATimeFormatString) do begin if ATimeFormatString[i] in ['a', 'A'] then begin inc(i); while (i <= Length(ATimeFormatString)) and (ATimeFormatString[i] in ['p', 'P', 'm', 'M', '/']) do inc(i); end else Result := Result + ATimeFormatString[i]; inc(i); end; end; {@@ Counts how many decimal places are coded into a given formatting string. @param AFormatString String with number format codes, such as '0.000' @param ADecChars Characters which are considered as symbols for decimals. For the fixed decimals, this is the '0'. Optional decimals are encoced as '#'. @return Count of decimal places found (3 in above example). } function CountDecs(AFormatString: String; ADecChars: TsDecsChars = ['0']): Byte; var i: Integer; begin Result := 0; i := 1; while (i <= Length(AFormatString)) do begin if AFormatString[i] = '.' then begin inc(i); while (i <= Length(AFormatString)) and (AFormatString[i] in ADecChars) do begin inc(i); inc(Result); end; exit; end else inc(i); end; end; {@@ The given format string is assumed to represent for time intervals, i.e. its first time symbol must be enclosed by square brackets. Checks if this is true, and adds the brackes if not. @param AFormatString String with time formatting codes @return Unchanged format string if its first time code is in square brackets (as in '[h]:nn:ss'), if not, the first time code is enclosed in square brackets. } function AddIntervalBrackets(AFormatString: String): String; var p: Integer; s1, s2: String; begin if AFormatString[1] = '[' then Result := AFormatString else begin p := pos(':', AFormatString); if p <> 0 then begin s1 := copy(AFormatString, 1, p-1); s2 := copy(AFormatString, p, Length(AFormatString)); Result := Format('[%s]%s', [s1, s2]); end else Result := Format('[%s]', [AFormatString]); end; end; {@@ Creates a long date format string out of a short date format string. Retains the order of year-month-day and the separators, but uses 4 digits for year and 3 digits of month. @param ADateFormat String with date formatting code representing a "short" date, such as 'dd/mm/yy' @return Format string modified to represent a "long" date, such as 'dd/mmm/yyyy' } function MakeLongDateFormat(ADateFormat: String): String; var i: Integer; begin Result := ''; i := 1; while i < Length(ADateFormat) do begin case ADateFormat[i] of 'y', 'Y': begin Result := Result + DupeString(ADateFormat[i], 4); while (i < Length(ADateFormat)) and (ADateFormat[i] in ['y','Y']) do inc(i); end; 'm', 'M': begin result := Result + DupeString(ADateFormat[i], 3); while (i < Length(ADateFormat)) and (ADateFormat[i] in ['m','M']) do inc(i); end; else Result := Result + ADateFormat[i]; inc(i); end; end; end; {@@ Modifies the short date format such that it has a two-digit year and a two-digit month. Retains the order of year-month-day and the separators. @param ADateFormat String with date formatting codes representing a "long" date, such as 'dd/mmm/yyyy' @return Format string modified to represent a "short" date, such as 'dd/mm/yy' } function MakeShortDateFormat(ADateFormat: String): String; var i: Integer; begin Result := ''; i := 1; while i < Length(ADateFormat) do begin case ADateFormat[i] of 'y', 'Y': begin Result := Result + DupeString(ADateFormat[i], 2); while (i < Length(ADateFormat)) and (ADateFormat[i] in ['y','Y']) do inc(i); end; 'm', 'M': begin result := Result + DupeString(ADateFormat[i], 2); while (i < Length(ADateFormat)) and (ADateFormat[i] in ['m','M']) do inc(i); end; else Result := Result + ADateFormat[i]; inc(i); end; end; end; {@@ Creates the formatstrings for the date/time codes "dm", "my", "ms" and "msz" out of the formatsettings. @param ACode Quick formatting code for parts of date/time number formats; "dm" = day + month "my" = month + year "ms" = minutes + seconds "msz" = minutes + seconds + fractions of a second @return String of formatting codes according to the parameter ACode } function SpecialDateTimeFormat(ACode: String; const AFormatSettings: TFormatSettings; ForWriting: Boolean): String; var pd, pm, py: Integer; sdf: String; MonthChar, MinuteChar, MillisecChar: Char; begin if ForWriting then begin MonthChar := 'M'; MinuteChar := 'm'; MillisecChar := '0'; end else begin MonthChar := 'm'; MinuteChar := 'n'; MillisecChar := 'z'; end; ACode := lowercase(ACode); sdf := lowercase(AFormatSettings.ShortDateFormat); pd := pos('d', sdf); pm := pos('m', sdf); py := pos('y', sdf); if ACode = 'dm' then begin Result := DupeString(MonthChar, 3); Result := IfThen(pd < py, 'd/'+Result, Result+'/d'); // d/mmm end else if ACode = 'my' then begin Result := DupeString(MonthChar, 3); Result := IfThen(pm < py, Result+'/yy', 'yy/'+Result); // mmm/yy end else if ACode = 'ms' then begin Result := DupeString(MinuteChar, 2) + ':ss'; // mm:ss end else if ACode = 'msz' then Result := DupeString(MinuteChar, 2) + ':ss.' + MillisecChar // mm:ss.z else Result := ACode; end; {@@ Currency formatting strings consist of three parts, separated by semicolons, which are valid for positive, negative or zero values. Splits such a formatting string at the positions of the semicolons and returns the sections. If semicolons are used for other purposed within sections they have to be quoted by " or escaped by \. If the formatting string contains less sections than three the missing strings are returned as empty strings. @param AFormatString String of number formatting codes. @param APositivePart First section of the formatting string which is valid for positive numbers (or positive and zero, if there are only two sections) @param ANegativePart Second section of the formatting string which is valid for negative numbers @param AZeroPart Third section of the formatting string for zero. } procedure SplitFormatString(const AFormatString: String; out APositivePart, ANegativePart, AZeroPart: String); procedure AddToken(AToken: Char; AWhere:Byte); begin case AWhere of 0: APositivePart := APositivePart + AToken; 1: ANegativePart := ANegativePart + AToken; 2: AZeroPart := AZeroPart + AToken; end; end; var P, PStart, PEnd: PChar; token: Char; where: Byte; // 0 = positive part, 1 = negative part, 2 = zero part begin APositivePart := ''; ANegativePart := ''; AZeroPart := ''; if AFormatString = '' then exit; PStart := PChar(@AFormatString[1]); PEnd := PStart + Length(AFormatString); P := PStart; where := 0; while P < PEnd do begin token := P^; case token of '"': begin // Let quoted text intact AddToken(token, where); inc(P); token := P^; while (P < PEnd) and (token <> '"') do begin AddToken(token, where); inc(P); token := P^; end; AddToken(token, where); end; ';': begin // Separator between parts inc(where); if where = 3 then exit; end; '\': begin // Skip "Escape" character and add next char immediately inc(P); token := P^; AddToken(token, where); end; else AddToken(token, where); end; inc(P); end; end; {@@ Creates a "time interval" format string having the first time code identifier in square brackets. @param Src Source format string, must be a time format string, like 'hh:nn' @param Dest Destination format string, will have the first time code element of the src format string in square brackets, like '[hh]:nn'. } procedure MakeTimeIntervalMask(Src: String; var Dest: String); var L: TStrings; begin L := TStringList.Create; try L.StrictDelimiter := true; L.Delimiter := ':'; L.DelimitedText := Src; if L[0][1] <> '[' then L[0] := '[' + L[0]; if L[0][Length(L[0])] <> ']' then L[0] := L[0] + ']'; Dest := L.DelimitedText; finally L.Free; end; end; {@@ Excel's unit of row heights is "twips", i.e. 1/20 point. Converts Twips to points. @param AValue Length value in twips @return Value converted to points } function TwipsToPts(AValue: Integer): Single; begin Result := AValue / 20; end; {@@ Converts points to twips (1 twip = 1/20 point) @param AValue Length value in points @return Value converted to twips } function PtsToTwips(AValue: Single): Integer; begin Result := round(AValue * 20); end; {@@ Converts centimeters to points (72 pts = 1 inch) @param AValue Length value in centimeters @return Value converted to points } function cmToPts(AValue: Double): Double; begin Result := AValue * 72 / 2.54; end; {@@ Converts points to centimeters @param AValue Length value in points @return Value converted to centimeters } function PtsToCm(AValue: Double): Double; begin Result := AValue / 72 * 2.54; end; {@@ Converts inches to points (72 pts = 1 inch) @param AValue Length value in inches @return Value converted to points } function InToPts(AValue: Double): Double; begin Result := AValue * 72; end; {@@ Converts millimeters to points (72 pts = 1 inch) @param AValue Length value in millimeters @return Value converted to points } function mmToPts(AValue: Double): Double; begin Result := AValue * 72 / 25.4; end; {@@ Converts points to millimeters @param AValue Length value in points @return Value converted to millimeters } function PtsToMM(AValue: Double): Double; begin Result := AValue / 72 * 25.4; end; {@@ Converts pixels to points. @param AValue Length value given in pixels @param AScreenPixelsPerInch Pixels per inch of the screen @return Value converted to points } function pxToPts(AValue, AScreenPixelsPerInch: Integer): Double; begin Result := (AValue / AScreenPixelsPerInch) * 72; end; {@@ Converts points to pixels @param AValue Length value given in points @param AScreenPixelsPerInch Pixels per inch of the screen @return Value converted to pixels } function PtsToPx(AValue: Double; AScreenPixelsPerInch: Integer): Integer; begin Result := Round(AValue / 72 * AScreenPixelsPerInch); end; {@@ Converts a HTML length string to points. The units are assumed to be the last two digits of the string, such as '1.25in' @param AValue HTML string representing a length with appended units code, such as '1.25in'. These unit codes are accepted: 'px' (pixels), 'pt' (points), 'in' (inches), 'mm' (millimeters), 'cm' (centimeters). @return Extracted length in points } function HTMLLengthStrToPts(AValue: String): Double; var units: String; x: Double; res: Word; begin if (Length(AValue) > 1) and (AValue[Length(AValue)] in ['a'..'z', 'A'..'Z']) then begin units := lowercase(Copy(AValue, Length(AValue)-1, 2)); val(copy(AValue, 1, Length(AValue)-2), x, res); // No hasseling with the decimal point... end else begin units := ''; val(AValue, x, res); end; if res <> 0 then raise Exception.CreateFmt('No valid number or units (%s)', [AValue]); if (units = 'pt') or (units = '') then Result := x else if units = 'in' then Result := InToPts(x) else if units = 'cm' then Result := cmToPts(x) else if units = 'mm' then Result := mmToPts(x) else if units = 'px' then Result := pxToPts(Round(x), ScreenPixelsPerInch) else raise Exception.Create('Unknown length units'); end; {@@ Converts a HTML color string to a TsColorValue. Need for the ODS file format. @param AValue HTML color string, such as '#FF0000' @return rgb color value in little endian byte-sequence. This value is compatible with the TColor data type of the graphics unit. } function HTMLColorStrToColor(AValue: String): TsColorValue; begin if AValue = '' then Result := scNotDefined else if AValue[1] = '#' then begin AValue[1] := '$'; Result := LongRGBToExcelPhysical(DWord(StrToInt(AValue))); end else begin AValue := lowercase(AValue); if AValue = 'red' then Result := $0000FF else if AValue = 'cyan' then Result := $FFFF00 else if AValue = 'blue' then Result := $FF0000 else if AValue = 'purple' then Result := $800080 else if AValue = 'yellow' then Result := $00FFFF else if AValue = 'lime' then Result := $00FF00 else if AValue = 'white' then Result := $FFFFFF else if AValue = 'black' then Result := $000000 else if (AValue = 'gray') or (AValue = 'grey') then Result := $808080 else if AValue = 'silver' then Result := $C0C0C0 else if AValue = 'maroon' then Result := $000080 else if AValue = 'green' then Result := $008000 else if AValue = 'olive' then Result := $008080; end; end; {@@ Converts an rgb color value to a string as used in HTML code (for ods) @param AValue RGB color value (compatible with the TColor data type of the graphics unit) @param AExcelDialect If TRUE, returned string is in Excels format for xlsx, i.e. in AARRGGBB notation, like '00FF0000' for "red" @return HTML-compatible string, like '#FF0000' (AExcelDialect = false) } function ColorToHTMLColorStr(AValue: TsColorValue; AExcelDialect: Boolean = false): String; type TRGB = record r,g,b,a: Byte end; var rgb: TRGB; begin rgb := TRGB(AValue); if AExcelDialect then Result := Format('00%.2x%.2x%.2x', [rgb.r, rgb.g, rgb.b]) else Result := Format('#%.2x%.2x%.2x', [rgb.r, rgb.g, rgb.b]); end; {@@ Converts a string encoded in UTF8 to a string usable in XML. For this purpose, some characters must be translated. @param AText input string encoded as UTF8 @return String usable in XML with some characters replaced by the HTML codes. } function UTF8TextToXMLText(AText: ansistring): ansistring; var Idx:Integer; WrkStr, AppoSt:ansistring; begin WrkStr:=''; for Idx:=1 to Length(AText) do begin case AText[Idx] of '&': begin AppoSt:=Copy(AText, Idx, 6); if (Pos('&', AppoSt) = 1) or (Pos('<', AppoSt) = 1) or (Pos('>', AppoSt) = 1) or (Pos('"', AppoSt) = 1) or (Pos(''', AppoSt) = 1) then begin //'&' is the first char of a special chat, it must not be converted WrkStr:=WrkStr + AText[Idx]; end else begin WrkStr:=WrkStr + '&'; end; end; '<': WrkStr:=WrkStr + '<'; '>': WrkStr:=WrkStr + '>'; '"': WrkStr:=WrkStr + '"'; '''':WrkStr:=WrkStr + '''; else WrkStr:=WrkStr + AText[Idx]; end; end; Result:=WrkStr; end; {******************************************************************************} {******************************************************************************} { Patch for SysUtils.FormatDateTime } { Remove when the feature of square brackets in time format masks is in rtl } {******************************************************************************} {******************************************************************************} {@@ Applies a formatting string to a date/time value and converts the number to a date/time string. This functionality is available in the SysUtils unit. But it is duplicated here to add a patch which is not available in stable fpc. } procedure DateTimeToString(out Result: string; const FormatStr: string; const DateTime: TDateTime; const FormatSettings: TFormatSettings; Options : TFormatDateTimeOptions = []); // Copied from "fpc/rtl/objpas/sysutils/datei.inc" var ResultLen: integer; ResultBuffer: array[0..255] of char; ResultCurrent: pchar; (* ---- not needed here --- {$IFDEF MSWindows} isEnable_E_Format : Boolean; isEnable_G_Format : Boolean; eastasiainited : boolean; procedure InitEastAsia; var ALCID : LCID; PriLangID , SubLangID : Word; begin ALCID := GetThreadLocale; PriLangID := ALCID and $3FF; if (PriLangID>0) then SubLangID := (ALCID and $FFFF) shr 10 else begin PriLangID := SysLocale.PriLangID; SubLangID := SysLocale.SubLangID; end; isEnable_E_Format := (PriLangID = LANG_JAPANESE) or (PriLangID = LANG_KOREAN) or ((PriLangID = LANG_CHINESE) and (SubLangID = SUBLANG_CHINESE_TRADITIONAL) ); isEnable_G_Format := (PriLangID = LANG_JAPANESE) or ((PriLangID = LANG_CHINESE) and (SubLangID = SUBLANG_CHINESE_TRADITIONAL) ); eastasiainited :=true; end; {$ENDIF MSWindows} *) procedure StoreStr(Str: PChar; Len: Integer); begin if ResultLen + Len < SizeOf(ResultBuffer) then begin StrMove(ResultCurrent, Str, Len); ResultCurrent := ResultCurrent + Len; ResultLen := ResultLen + Len; end; end; procedure StoreString(const Str: string); var Len: integer; begin Len := Length(Str); if ResultLen + Len < SizeOf(ResultBuffer) then begin StrMove(ResultCurrent, pchar(Str), Len); ResultCurrent := ResultCurrent + Len; ResultLen := ResultLen + Len; end; end; procedure StoreInt(Value, Digits: Integer); var S: string[16]; Len: integer; begin System.Str(Value:Digits, S); for Len := 1 to Length(S) do begin if S[Len] = ' ' then S[Len] := '0' else Break; end; StoreStr(pchar(@S[1]), Length(S)); end ; var Year, Month, Day, DayOfWeek, Hour, Minute, Second, MilliSecond: word; procedure StoreFormat(const FormatStr: string; Nesting: Integer; TimeFlag: Boolean); var Token, lastformattoken, prevlasttoken: char; FormatCurrent: pchar; FormatEnd: pchar; Count: integer; Clock12: boolean; P: pchar; tmp: integer; isInterval: Boolean; begin if Nesting > 1 then // 0 is original string, 1 is included FormatString Exit; FormatCurrent := PChar(FormatStr); FormatEnd := FormatCurrent + Length(FormatStr); Clock12 := false; isInterval := false; P := FormatCurrent; // look for unquoted 12-hour clock token while P < FormatEnd do begin Token := P^; case Token of '''', '"': begin Inc(P); while (P < FormatEnd) and (P^ <> Token) do Inc(P); end; 'A', 'a': begin if (StrLIComp(P, 'A/P', 3) = 0) or (StrLIComp(P, 'AMPM', 4) = 0) or (StrLIComp(P, 'AM/PM', 5) = 0) then begin Clock12 := true; break; end; end; end; // case Inc(P); end ; token := #255; lastformattoken := ' '; prevlasttoken := 'H'; while FormatCurrent < FormatEnd do begin Token := UpCase(FormatCurrent^); Count := 1; P := FormatCurrent + 1; case Token of '''', '"': begin while (P < FormatEnd) and (p^ <> Token) do Inc(P); Inc(P); Count := P - FormatCurrent; StoreStr(FormatCurrent + 1, Count - 2); end ; 'A': begin if StrLIComp(FormatCurrent, 'AMPM', 4) = 0 then begin Count := 4; if Hour < 12 then StoreString(FormatSettings.TimeAMString) else StoreString(FormatSettings.TimePMString); end else if StrLIComp(FormatCurrent, 'AM/PM', 5) = 0 then begin Count := 5; if Hour < 12 then StoreStr(FormatCurrent, 2) else StoreStr(FormatCurrent+3, 2); end else if StrLIComp(FormatCurrent, 'A/P', 3) = 0 then begin Count := 3; if Hour < 12 then StoreStr(FormatCurrent, 1) else StoreStr(FormatCurrent+2, 1); end else raise EConvertError.Create('Illegal character in format string'); end ; '/': StoreStr(@FormatSettings.DateSeparator, 1); ':': StoreStr(@FormatSettings.TimeSeparator, 1); '[': if (fdoInterval in Options) then isInterval := true else StoreStr(FormatCurrent, 1); ']': if (fdoInterval in Options) then isInterval := false else StoreStr(FormatCurrent, 1); ' ', 'C', 'D', 'H', 'M', 'N', 'S', 'T', 'Y', 'Z', 'F' : begin while (P < FormatEnd) and (UpCase(P^) = Token) do Inc(P); Count := P - FormatCurrent; case Token of ' ': StoreStr(FormatCurrent, Count); 'Y': begin if Count > 2 then StoreInt(Year, 4) else StoreInt(Year mod 100, 2); end; 'M': begin if isInterval and ((prevlasttoken = 'H') or TimeFlag) then StoreInt(Minute + (Hour + trunc(abs(DateTime))*24)*60, 0) else if (lastformattoken = 'H') or TimeFlag then begin if Count = 1 then StoreInt(Minute, 0) else StoreInt(Minute, 2); end else begin case Count of 1: StoreInt(Month, 0); 2: StoreInt(Month, 2); 3: StoreString(FormatSettings.ShortMonthNames[Month]); else StoreString(FormatSettings.LongMonthNames[Month]); end; end; end; 'D': begin case Count of 1: StoreInt(Day, 0); 2: StoreInt(Day, 2); 3: StoreString(FormatSettings.ShortDayNames[DayOfWeek]); 4: StoreString(FormatSettings.LongDayNames[DayOfWeek]); 5: StoreFormat(FormatSettings.ShortDateFormat, Nesting+1, False); else StoreFormat(FormatSettings.LongDateFormat, Nesting+1, False); end ; end ; 'H': if isInterval then StoreInt(Hour + trunc(abs(DateTime))*24, 0) else if Clock12 then begin tmp := hour mod 12; if tmp=0 then tmp:=12; if Count = 1 then StoreInt(tmp, 0) else StoreInt(tmp, 2); end else begin if Count = 1 then StoreInt(Hour, 0) else StoreInt(Hour, 2); end; 'N': if isInterval then StoreInt(Minute + (Hour + trunc(abs(DateTime))*24)*60, 0) else if Count = 1 then StoreInt(Minute, 0) else StoreInt(Minute, 2); 'S': if isInterval then StoreInt(Second + (Minute + (Hour + trunc(abs(DateTime))*24)*60)*60, 0) else if Count = 1 then StoreInt(Second, 0) else StoreInt(Second, 2); 'Z': if Count = 1 then StoreInt(MilliSecond, 0) else StoreInt(MilliSecond, 3); 'T': if Count = 1 then StoreFormat(FormatSettings.ShortTimeFormat, Nesting+1, True) else StoreFormat(FormatSettings.LongTimeFormat, Nesting+1, True); 'C': begin StoreFormat(FormatSettings.ShortDateFormat, Nesting+1, False); if (Hour<>0) or (Minute<>0) or (Second<>0) then begin StoreString(' '); StoreFormat(FormatSettings.LongTimeFormat, Nesting+1, True); end; end; 'F': begin StoreFormat(FormatSettings.ShortDateFormat, Nesting+1, False); StoreString(' '); StoreFormat(FormatSettings.LongTimeFormat, Nesting+1, True); end; (* ------------ not needed here... {$IFDEF MSWindows} 'E': begin if not Eastasiainited then InitEastAsia; if Not(isEnable_E_Format) then StoreStr(@FormatCurrent^, 1) else begin while (P < FormatEnd) and (UpCase(P^) = Token) do P := P + 1; Count := P - FormatCurrent; StoreString(ConvertEraYearString(Count,Year,Month,Day)); end; prevlasttoken := lastformattoken; lastformattoken:=token; end; 'G': begin if not Eastasiainited then InitEastAsia; if Not(isEnable_G_Format) then StoreStr(@FormatCurrent^, 1) else begin while (P < FormatEnd) and (UpCase(P^) = Token) do P := P + 1; Count := P - FormatCurrent; StoreString(ConvertEraString(Count,Year,Month,Day)); end; prevlasttoken := lastformattoken; lastformattoken:=token; end; {$ENDIF MSWindows} *) end; prevlasttoken := lastformattoken; lastformattoken := token; end; else StoreStr(@Token, 1); end ; Inc(FormatCurrent, Count); end; end; begin (* {$ifdef MSWindows} eastasiainited:=false; {$endif MSWindows} *) DecodeDateFully(DateTime, Year, Month, Day, DayOfWeek); DecodeTime(DateTime, Hour, Minute, Second, MilliSecond); ResultLen := 0; ResultCurrent := @ResultBuffer[0]; if FormatStr <> '' then StoreFormat(FormatStr, 0, False) else StoreFormat('C', 0, False); ResultBuffer[ResultLen] := #0; result := StrPas(@ResultBuffer[0]); end ; {@@ Applies a formatting string to a date/time value and converts the number to a date/time string. This functionality is available in the SysUtils unit. But it is duplicated here to add a patch which is not available in stable fpc. } procedure DateTimeToString(out Result: string; const FormatStr: string; const DateTime: TDateTime; Options : TFormatDateTimeOptions = []); begin DateTimeToString(Result, FormatStr, DateTime, DefaultFormatSettings, Options); end; {@@ Applies a formatting string to a date/time value and converts the number to a date/time string. This functionality is available in the SysUtils unit. But it is duplicated here to add a patch which is not available in stable fpc. } function FormatDateTime(const FormatStr: string; DateTime: TDateTime; Options : TFormatDateTimeOptions = []): string; begin DateTimeToString(Result, FormatStr, DateTime, DefaultFormatSettings,Options); end; {@@ Applies a formatting string to a date/time value and converts the number to a date/time string. This functionality is available in the SysUtils unit. But it is duplicated here to add a patch which is not available in stable fpc. } function FormatDateTime(const FormatStr: string; DateTime: TDateTime; const FormatSettings: TFormatSettings; Options : TFormatDateTimeOptions = []): string; begin DateTimeToString(Result, FormatStr, DateTime, FormatSettings,Options); end; {@@ Extracts compare information from an input string such as "<2.4". Is needed for some Excel-strings. @param AString Input string starting with "<", "<=", ">", ">=", "<>" or "=" If this start code is missing a "=" is assumed. @param ACompareOp Identifier for the comparing operation extracted - see TsCompareOperation @return Input string with the comparing characters stripped. } function AnalyzeComparestr(AString: String; out ACompareOp: TsCompareOperation): String; procedure RemoveChars(ACount: Integer; ACompare: TsCompareOperation); begin ACompareOp := ACompare; if ACount = 0 then Result := AString else Result := Copy(AString, 1+ACount, Length(AString)); end; begin if Length(AString) > 1 then case AString[1] of '<' : case AString[2] of '>' : RemoveChars(2, coNotEqual); '=' : RemoveChars(2, coLessEqual); else RemoveChars(1, coLess); end; '>' : case AString[2] of '=' : RemoveChars(2, coGreaterEqual); else RemoveChars(1, coGreater); end; '=' : RemoveChars(1, coEqual); else RemoveChars(0, coEqual); end else RemoveChars(0, coEqual); end; procedure AppendToStream(AStream: TStream; const AString: string); begin if Length(AString) > 0 then AStream.WriteBuffer(AString[1], Length(AString)); end; procedure AppendToStream(AStream: TStream; const AString1, AString2: String); begin AppendToStream(AStream, AString1); AppendToStream(AStream, AString2); end; procedure AppendToStream(AStream: TStream; const AString1, AString2, AString3: String); begin AppendToStream(AStream, AString1); AppendToStream(AStream, AString2); AppendToStream(AStream, AString3); end; function PosInMemory(AMagic: QWord; ABuffer: PByteArray; ABufSize: Integer): Integer; var i, j: Integer; MagicBytes: Array[0..7] of byte absolute AMagic; found: Boolean; begin Result := -1; for i:=0 to ABufSize - SizeOf(QWord) do begin if (ABuffer^[i] = MagicBytes[0]) then begin found := true; for j:=1 to 7 do if ABuffer^[i+j] <> MagicBytes[j] then begin found := false; break; end; if found then begin Result := i; exit; end; end; end; end; { Modifying colors } { Next function are copies of GraphUtils to avoid a dependence on the Graphics unit. } const HUE_000 = 0; HUE_060 = 43; HUE_120 = 85; HUE_180 = 128; HUE_240 = 170; procedure RGBtoHLS(const R, G, B: Byte; out H, L, S: Byte); var cMax, cMin: Integer; // max and min RGB values Rdelta, Gdelta, Bdelta: Byte; // intermediate value: % of spread from max diff: Integer; begin // calculate lightness cMax := MaxIntValue([R, G, B]); cMin := MinIntValue([R, G, B]); L := (integer(cMax) + cMin + 1) div 2; diff := cMax - cMin; if diff = 0 then begin // r=g=b --> achromatic case S := 0; H := 0; end else begin // chromatic case // saturation if L <= 128 then S := integer(diff * 255) div (cMax + cMin) else S := integer(diff * 255) div (510 - cMax - cMin); // hue Rdelta := (cMax - R); Gdelta := (cMax - G); Bdelta := (cMax - B); if R = cMax then H := (HUE_000 + integer(Bdelta - Gdelta) * HUE_060 div diff) and $ff else if G = cMax then H := HUE_120 + integer(Rdelta - Bdelta) * HUE_060 div diff else H := HUE_240 + integer(Gdelta - Rdelta) * HUE_060 div diff; end; end; procedure HLStoRGB(const H, L, S: Byte; out R, G, B: Byte); // utility routine for HLStoRGB function HueToRGB(const n1, n2: Byte; Hue: Integer): Byte; begin if Hue > 255 then Dec(Hue, 255) else if Hue < 0 then Inc(Hue, 255); // return r,g, or b value from this tridrant case Hue of HUE_000..HUE_060 - 1: Result := n1 + (n2 - n1) * Hue div HUE_060; HUE_060..HUE_180 - 1: Result := n2; HUE_180..HUE_240 - 1: Result := n1 + (n2 - n1) * (HUE_240 - Hue) div HUE_060; else Result := n1; end; end; var n1, n2: Integer; begin if S = 0 then begin // achromatic case R := L; G := L; B := L; end else begin // chromatic case // set up magic numbers if L < 128 then begin n2 := L + (L * S) div 255; n1 := 2 * L - n2; end else begin n2 := S + L - (L * S) div 255; n1 := 2 * L - n2 - 1; end; // get RGB R := HueToRGB(n1, n2, H + HUE_120); G := HueToRGB(n1, n2, H); B := HueToRGB(n1, n2, H - HUE_120); end; end; { Excel defines theme colors and applies a "tint" factor (-1...+1) to darken or brighten them. The algorithm is described in http://msdn.microsoft.com/en-us/library/documentformat.openxml.spreadsheet.backgroundcolor.aspx (with the exception that max hue is 240, nur 255!) } function TintedColor(AColor: TsColorValue; tint: Double): TsColorValue; const HLSMAX = 255; var r, g, b: byte; h, l, s: Byte; lum: Double; begin if tint = 0 then begin Result := AColor; exit; end; r := TRGBA(AColor).r; g := TRGBA(AColor).g; b := TRGBA(AColor).b; RGBToHLS(r, g, b, h, l, s); lum := l; if tint < 0 then lum := lum * (1.0 + tint) else if tint > 0 then lum := lum * (1.0-tint) + (HLSMAX - HLSMAX * (1.0-tint)); l := Min(255, round(lum)); HLSToRGB(h, l, s, r, g, b); TRGBA(Result).r := r; TRGBA(Result).g := g; TRGBA(Result).b := b; TRGBA(Result).a := 0; end; {$PUSH}{$HINTS OFF} {@@ Silence warnings due to an unused parameter } procedure Unused(const A1); // code "borrowed" from TAChart begin end; {@@ Silence warnings due to two unused parameters } procedure Unused(const A1, A2); // code "borrowed" from TAChart begin end; {@@ Silence warnings due to three unused parameters } procedure Unused(const A1, A2, A3); // code adapted from TAChart begin end; {$POP} { For debugging only } {@@ Write the fonts stored for a given workbook to a file. } procedure DumpFontsToFile(AWorkbook: TsWorkbook; AFileName: String); var L: TStringList; i: Integer; fnt: TsFont; begin L := TStringList.Create; try for i:=0 to AWorkbook.GetFontCount-1 do begin fnt := AWorkbook.GetFont(i); if fnt = nil then L.Add(Format('#%.3d: ---------------', [i])) else L.Add(Format('#%.3d: %-15s %4.1f %s%s%s%s %s', [ i, fnt.FontName, fnt.Size, IfThen(fssBold in fnt.Style, 'b', '.'), IfThen(fssItalic in fnt.Style, 'i', '.'), IfThen(fssUnderline in fnt.Style, 'u', '.'), IfThen(fssStrikeOut in fnt.Style, 's', '.'), AWorkbook.GetPaletteColorAsHTMLStr(fnt.Color) ])); end; L.SaveToFile(AFileName); finally L.Free; end; end; end.