pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity
Files
b9df429d5bb26fa36cd68b76841ade4fd85dd7ba
lazarus-ccr/components/fpspreadsheet/fpsutils.pas

1366 lines
39 KiB
ObjectPascal
Raw Blame History

{
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;
// Exported types
type
TsSelectionDirection = (fpsVerticalSelection, fpsHorizontalSelection);
TsDecsChars = set of char;
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';
// 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;
var AFirstCellRow, AFirstCellCol, ACount: Integer;
var ADirection: TsSelectionDirection): Boolean;
function ParseCellRangeString(const AStr: string;
var AFirstCellRow, AFirstCellCol, ALastCellRow, ALastCellCol: Integer;
var AFlags: TsRelFlags): Boolean;
function ParseCellString(const AStr: string;
var ACellRow, ACellCol: Integer; var AFlags: TsRelFlags): Boolean; overload;
function ParseCellString(const AStr: string;
var ACellRow, ACellCol: Integer): Boolean; overload;
function ParseCellRowString(const AStr: string;
var AResult: Integer): Boolean;
function ParseCellColString(const AStr: string;
var AResult: Integer): Boolean;
function GetColString(AColIndex: Integer): String;
function UTF8TextToXMLText(AText: ansistring): ansistring;
function TwipsToMillimeters(AValue: Integer): Single;
function MillimetersToTwips(AValue: Single): Integer;
function IfThen(ACondition: Boolean; AValue1,AValue2: TsNumberFormat): TsNumberFormat; overload;
function IsDateTimeFormat(AFormat: TsNumberFormat): Boolean;
(*
function IsCurrencyFormat(s: String; out Decimals: Byte; out CurrSymbol: String;
out IsCurrencyRedFmt, IsCurrencyDashFmt: Boolean): Boolean;
function IsExpNumberFormat(s: String; out Decimals: Byte; out IsSci: Boolean): Boolean;
function IsFixedNumberFormat(s: String; out Decimals: Byte): Boolean;
function IsPercentNumberFormat(s: String; out Decimals: Byte): Boolean;
function IsThousandSepNumberFormat(s: String; out Decimals: Byte): Boolean;
function IsDateFormat(s: String; out IsLong: Boolean): Boolean;
{function IsTimeFormat(s: String; out isLong, isAMPM, isInterval: Boolean;
out SecDecimals: Byte): Boolean;
*)
function BuildNumberFormatString(ANumberFormat: TsNumberFormat;
const AFormatSettings: TFormatSettings; ADecimals: Integer = -1;
ACurrencySymbol: String = '?'): String;
function BuildDateTimeFormatString(ANumberFormat: TsNumberFormat;
const AFormatSettings: TFormatSettings; AFormatString: String = ''): String;
function StripAMPM(const ATimeFormatString: String): String;
function CountDecs(AFormatString: String; ADecChars: TsDecsChars = ['0']): Byte;
function SciFloat(AValue: Double; ADecimals: Byte): String;
//function TimeIntervalToString(AValue: TDateTime; AFormatStr: String): String;
procedure MakeTimeIntervalMask(Src: String; var Dest: String);
function FormatDateTimeEx(const FormatStr: string; DateTime: TDateTime): String; overload;
function FormatDateTimeEx(const FormatStr: string; DateTime: TDateTime;
AFormatSettings: TFormatSettings): string; overload;
implementation
uses
Math;
{
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.
These routines 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.
}
function WordToLE(AValue: Word): Word;
begin
{$IFDEF FPC}
Result := NtoLE(AValue);
{$ELSE}
Result := AValue;
{$ENDIF}
end;
function DWordToLE(AValue: Cardinal): Cardinal;
begin
{$IFDEF FPC}
Result := NtoLE(AValue);
{$ELSE}
Result := AValue;
{$ENDIF}
end;
function IntegerToLE(AValue: Integer): Integer;
begin
{$IFDEF FPC}
Result := NtoLE(AValue);
{$ELSE}
Result := AValue;
{$ENDIF}
end;
function WordLEtoN(AValue: Word): Word;
begin
{$IFDEF FPC}
Result := LEtoN(AValue);
{$ELSE}
Result := AValue;
{$ENDIF}
end;
function DWordLEtoN(AValue: Cardinal): Cardinal;
begin
{$IFDEF FPC}
Result := LEtoN(AValue);
{$ELSE}
Result := AValue;
{$ENDIF}
end;
function WideStringToLE(const AValue: WideString): WideString;
var
j: integer;
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;
function WideStringLEToN(const AValue: WideString): WideString;
var
j: integer;
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 RGB part of a LongRGB logical structure to its physical representation
IOW: RGBA (where A is 0 and omitted in the function call) => ABGR
Needed for conversion of palette colors. }
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
}
function ParseIntervalString(const AStr: string;
var AFirstCellRow, AFirstCellCol, ACount: Integer;
var ADirection: TsSelectionDirection): Boolean;
var
//Cells: TStringList;
LastCellRow, LastCellCol: Integer;
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.
Return also information on relative/absolute cells.
}
function ParseCellRangeString(const AStr: string;
var AFirstCellRow, AFirstCellCol, ALastCellRow, ALastCellCol: Integer;
var AFlags: TsRelFlags): Boolean;
var
p: Integer;
s: String;
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, AFlags);
if not Result then exit;
if (rfRelRow in AFlags) then begin
Include(AFlags, rfRelRow2);
Exclude(AFlags, rfRelRow);
end;
if (rfRelCol in AFlags) then begin
Include(AFlags, rfRelCol2);
Exclude(AFlags, rfRelCol);
end;
// Analyze part before the colon
s := copy(AStr, 1, p-1);
Result := ParseCellString(s, AFirstCellRow, AFirstCellCol, AFlags);
end;
{@@
Parses a cell string, like 'A1' into zero-based column and row numbers
The parser is a simple state machine, with the following states:
0 - Reading Column part 1 (necesserely needs a letter)
1 - Reading Column part 2, but could be the first number as well
2 - Reading Row
'AFlags' indicates relative addresses.
}
function ParseCellString(const AStr: string; var ACellRow, ACellCol: Integer;
var AFlags: TsRelFlags): Boolean;
var
i: Integer;
state: Integer;
Col, Row: string;
lChar: Char;
isAbs: Boolean;
const
cLetters = ['A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L',
'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'W', 'X', 'Y', 'Z'];
cDigits = ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9'];
begin
// Starting state
Result := True;
state := 0;
Col := '';
Row := '';
AFlags := [rfRelCol, rfRelRow];
isAbs := false;
// Separates the string into a row and a col
for i := 1 to Length(AStr) do
begin
lChar := AStr[i];
if lChar = '$' then begin
if isAbs then
exit(false);
isAbs := true;
continue;
end;
case state of
0:
begin
if lChar in cLetters then
begin
Col := lChar;
if isAbs then
Exclude(AFlags, rfRelCol);
isAbs := false;
state := 1;
end
else Exit(False);
end;
1:
begin
if lChar in cLetters then
Col := Col + lChar
else if lChar in cDigits then
begin
Row := lChar;
if isAbs then
Exclude(AFlags, rfRelRow);
isAbs := false;
state := 2;
end
else Exit(False);
end;
2:
begin
if lChar in cDigits then Row := Row + lChar
else Exit(False);
end;
end;
end;
// Now parses each separetely
ParseCellRowString(Row, ACellRow);
ParseCellColString(Col, ACellCol);
end;
{ for compatibility with old version which does not return flags for relative
cell addresses }
function ParseCellString(const AStr: string;
var ACellRow, ACellCol: Integer): Boolean;
var
flags: TsRelFlags;
begin
ParseCellString(AStr, ACellRow, ACellCol, flags);
end;
function ParseCellRowString(const AStr: string; var AResult: Integer): Boolean;
begin
try
AResult := StrToInt(AStr) - 1;
except
Result := False;
end;
Result := True;
end;
function ParseCellColString(const AStr: string; var AResult: Integer): 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;
function GetColString(AColIndex: Integer): String;
begin
if AColIndex < 26 then
Result := Letter(AColIndex)
else
if AColIndex < 26*26 then
Result := Letter(AColIndex div 26) + Letter(AColIndex mod 26)
else
if AColIndex < 26*26*26 then
Result := Letter(AColIndex div (26*26)) + Letter((AColIndex mod (26*26)) div 26)
+ Letter(AColIndex mod (26*26*26))
else
Result := 'too big';
end;
{In XML files some chars must be translated}
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('&amp;', AppoSt) = 1) or
(Pos('&lt;', AppoSt) = 1) or
(Pos('&gt;', AppoSt) = 1) or
(Pos('&quot;', AppoSt) = 1) or
(Pos('&apos;', 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 + '&amp;';
end;
end;
'<': WrkStr:=WrkStr + '&lt;';
'>': WrkStr:=WrkStr + '&gt;';
'"': WrkStr:=WrkStr + '&quot;';
'''':WrkStr:=WrkStr + '&apos;';
else
WrkStr:=WrkStr + AText[Idx];
end;
end;
Result:=WrkStr;
end;
{ Excel's unit of row heights is "twips", i.e. 1/20 point. 72 pts = 1 inch = 25.4 mm
The procedure TwipsToMillimeters performs the conversion to millimeters. }
function TwipsToMillimeters(AValue: Integer): Single;
begin
Result := 25.4 * AValue / (20 * 72);
end;
{ Converts Millimeters to Twips, i.e. 1/20 pt }
function MillimetersToTwips(AValue: Single): Integer;
begin
Result := Round((AValue * 20 * 72) / 25.4);
end;
{ Returns either AValue1 or AValue2, depending on the condition.
For reduciton of typing... }
function IfThen(ACondition: Boolean; AValue1, AValue2: TsNumberFormat): TsNumberFormat;
begin
if ACondition then Result := AValue1 else Result := AValue2;
end;
{ Format checking procedures }
function IsDateTimeFormat(AFormat: TsNumberFormat): Boolean;
begin
Result := AFormat in [nfFmtDateTime, nfShortDateTime, nfShortDate, nfLongDate,
nfShortTime. nfLongTime, nfShortTimeAM, nfLongTimeAM, nfTimeInterval];
end;
(*
{ This simple parsing procedure of the Excel format string checks for a fixed
float format s, i.e. s can be '0', '0.00', '000', '0,000', and returns the
number of decimals, i.e. number of zeros behind the decimal point }
function IsFixedNumberFormat(s: String; out Decimals: Byte): Boolean;
var
i: Integer;
p: Integer;
decs: String;
begin
Decimals := 0;
// Excel time formats with milliseconds ("mm:ss.000") can be incorrectly
// detected as fixed number formats. Check this case at first.
if pos('s.0', s) > 0 then begin
Result := false;
exit;
end;
// Check if s is a valid format mask.
try
FormatFloat(s, 1.0);
except
on EConvertError do begin
Result := false;
exit;
end;
end;
// If it is count the zeros - each one is a decimal.
if s = '0' then
Result := true
else begin
p := pos('.', s); // position of decimal point;
if p = 0 then begin
Result := false;
end else begin
Result := true;
for i:= p+1 to Length(s) do
if s[i] = '0' then begin
inc(Decimals)
end
else
exit; // ignore characters after the last 0
end;
end;
end;
{ This function checks whether the format string corresponds to a thousand
separator format like "#,##0.000' and returns the number of fixed decimals
(i.e. zeros after the decimal point) }
function IsThousandSepNumberFormat(s: String; out Decimals: Byte): Boolean;
var
i, p: Integer;
begin
Decimals := 0;
// Check if s is a valid format string
try
FormatFloat(s, 1.0);
except
on EConvertError do begin
Result := false;
exit;
end;
end;
// If it is look for the thousand separator. If found count decimals.
Result := (Pos(',', s) > 0);
if Result then begin
p := pos('.', s);
if p > 0 then
for i := p+1 to Length(s) do
if s[i] = '0' then
inc(Decimals)
else
exit; // ignore format characters after the last 0
end;
end;
{ This function checks whether the format string corresponds to percent
formatting and determines the number of decimals }
function IsPercentNumberFormat(s: String; out Decimals: Byte): Boolean;
var
i, p: Integer;
begin
Decimals := 0;
// The signature of the percent format is a percent sign at the end of the
// format string.
Result := (s <> '') and (s[Length(s)] = '%');
if Result then begin
// Check for a valid format string
try
FormatDateTime(s, 1.0);
except
on EConvertError do begin
Result := false;
exit;
end;
end;
// Count decimals
p := pos('.', s);
if p > 0 then
for i := p+1 to Length(s)-1 do
if s[i] = '0' then
inc(Decimals)
else
exit; // ignore characters after last 0
end;
end;
{ This function checks whether the format string corresponds to a currency format. }
function IsCurrencyFormat(s: String; out Decimals: Byte; out CurrSymbol: String;
out IsCurrencyRedFmt, IsCurrencyDashFmt: Boolean): Boolean;
begin
Result := false; // TO DO !!!!
end;
{ This function checks whether the format string corresponds to exponential
formatting and determines the number of decimals. If it contains a # character
the function assumes a "scientific" format rounding the exponent to multiples
of 2. }
function IsExpNumberFormat(s: String; out Decimals: Byte;
out IsSci: Boolean): Boolean;
var
i, pdp, pe, ph: Integer;
begin
Result := false;
Decimals := 0;
IsSci := false;
if SameText(s, 'General') then
exit;
// Check for a valid format string
try
FormatDateTime(s, 1.0);
except
on EConvertError do begin
exit;
end;
end;
pe := pos('e', lowercase(s));
result := pe > 0;
if Result then begin
// The next character must be a "+", "-", or "0"
if (pe = Length(s)) or not (s[pe+1] in ['+', '-', '0']) then begin
Result := false;
exit;
end;
// Count decimals
pdp := pos('.', s);
if (pdp > 0) then begin
if pdp < pe then
for i:=pdp+1 to pe-1 do
if s[i] = '0' then
inc(Decimals)
else
break; // ignore characters after last 0
end;
// Look for hash signs # as indicator of the "scientific" format
ph := pos('#', s);
if ph > 0 then IsSci := true;
end;
end;
*)
{ IsDateFormat checks if the format string s corresponds to a date format }
function IsDateFormat(s: String; out IsLong: Boolean): Boolean;
begin
s := Lowercase(s);
// Day, month, year are separated by a slash
// We also check part of the year/month/day symbol because there may be
// other control code with a slash.
Result := (pos('y/', s) > 0) or (pos('m/', s) > 0) or (pos('/m', s) > 0) or (pos('/d', s) > 0);
if Result then
// Check validity of format string
try
FormatDateTime(s, now);
s := Lowercase(s);
isLong := (pos('mmm', s) <> 0) or (pos('mmmm', s) <> 0);
except on EConvertError do
Result := false;
end;
end;
{ IsTimeFormat checks if the format string s is a time format. isLong is
true if the string contains hours, minutes and seconds (two colons).
isAMPM is true if the string contains "AM/PM", "A/P" or "AMPM".
isInterval is true if the string contains square bracket codes for time intervals.
SecDecimals is the number of decimals for the seconds. }
function IsTimeFormat(s: String; out isLong, isAMPM, isInterval: Boolean;
out SecDecimals: Byte): Boolean;
var
p, pdp, i, count: Integer;
begin
isLong := false;
isAMPM := false;
SecDecimals := 0;
// Time parts are separated by a colon
p := pos(':', s);
result := p > 0;
if Result then begin
count := 1;
s := Uppercase(s);
// Seek for "H:MM:SS" or "H:MM" to see if it is a long or short time format.
if pos('H:MM:SS', s) <> 0 then
isLong := true
else
if pos('H:MM', s) <> 0 then
isLong := false
else
// If there are is a second colon s is a "long" time format
for i:=p+1 to Length(s) do
if s[i] = ':' then begin
isLong := true;
break;
end;
// Seek for "AM/PM" etc to detect that specific format
isAMPM := (pos('AM/PM', s) > 0) or (pos('A/P', s) > 0) or (pos('AMPM', s) > 0);
// Look for special square bracket symbols indicating the interval format.
isInterval := (pos('[H]', s) <> 0) or (pos('[HH]', s) <> 0) or
(pos('[M]', s) <> 0) or (pos('[MM]', s) <> 0) or
(pos('[N]', s) <> 0) or (pos('[NN]', s) <> 0) or
(pos('[S]', s) <> 0) or (pos('[SS]', s) <> 0);
// Count decimals
pdp := pos('.', s);
if (pdp > 0) then
for i:=pdp+1 to Length(s) do
if (s[i] in ['0', 'z', 'Z']) then
inc(SecDecimals)
else
break; // ignore characters after last 0
// Check validity of format string
try
FormatDateTime(s, now);
except on EConvertError do
Result := false;
end;
end;
end;
{ Builds a date/time format string from the numberformat code. If the format code
is nfFmtDateTime the given AFormatString is used. AFormatString can use the
abbreviations "dm" (for "d/mmm"), "my" (for "mmm/yy"), "ms" (for "mm:ss")
and "msz" (for "mm:ss.z"). }
function BuildDateTimeFormatString(ANumberFormat: TsNumberFormat;
const AFormatSettings: TFormatSettings; AFormatString: String = '') : string;
var
fmt: String;
begin
case ANumberFormat of
nfFmtDateTime:
begin
fmt := lowercase(AFormatString);
if (fmt = 'dm') then Result := 'd/mmm'
else if (fmt = 'my') then Result := 'mmm/yy'
else if (fmt = 'ms') then Result := 'nn:ss'
else if (fmt = 'msz') then Result := 'nn:ss.z'
else Result := AFormatString;
end;
nfShortDateTime:
Result := AFormatSettings.ShortDateFormat + ' ' + FormatSettings.ShortTimeFormat;
nfShortDate:
Result := AFormatSettings.ShortDateFormat;
nfLongDate:
Result := AFormatSettings.LongDateFormat;
nfShortTime:
Result := StripAMPM(AFormatSettings.ShortTimeFormat);
nfLongTime:
Result := StripAMPM(AFormatSettings.LongTimeFormat);
nfShortTimeAM:
begin
Result := AFormatSettings.ShortTimeFormat;
if pos('a', lowercase(AFormatSettings.ShortTimeFormat)) = 0 then
Result := Format('%s %s/%s', [Result, AFormatSettings.TimeAMString, AFormatSettings.TimePMString]);
end;
nfLongTimeAM:
begin
Result := AFormatSettings.LongTimeFormat;
if pos('a', lowercase(AFormatSettings.LongTimeFormat)) = 0 then
Result := Format('%s %s/%s', [Result, AFormatSettings.TimeAMString, AFormatSettings.TimePMString]);
end;
nfTimeInterval:
if AFormatString = '' then
Result := '[h]:mm:ss'
else
Result := AFormatString;
end;
end;
{ Builds a number format string from the numberformat code, the count of
decimals, and the currencysymbol (if not empty). }
function BuildNumberFormatString(ANumberFormat: TsNumberFormat;
const AFormatSettings: TFormatSettings; ADecimals: Integer = -1;
ACurrencySymbol: String = '?'): String;
const
POS_FMT: array[0..3] of string = ( //0: value, 1: currency symbol
'"%1:s"%0:s',
'%0:s"%1:s"',
'"%1:s" %0:s',
'%0:s "%1:s"'
);
NEG_FMT: array[0..15] of string = (
'("%1:s"%0:s)', // 0
'-"%1:s"%0:s', // 1
'"%1:s"-%0:s', // 2
'"%1:s"%0:s-', // 3
'(%0:s"%1:s")', // 4
'-%0:s"%1:s"', // 5
'-%0:s-"%1:s"', // 6
'%0:s"%1:s"-', // 7
'-%0:s "%1:s"', // 8
'-"%1:s" %0:s', // 9
'%0:s "%1:s"-', // 10
'"%1:s" %0:s-', // 11
'"%1:s" -%0:s', // 12
'%0:s- "%1:s"', // 13
'("%1:s" %0:s)', // 14
'(%0:s "%1:s")' // 15
);
var
decs: String;
cf, ncf: Byte;
begin
Result := '';
cf := AFormatSettings.CurrencyFormat;
ncf := AFormatSettings.NegCurrFormat;
if ADecimals = -1 then ADecimals := AFormatSettings.CurrencyDecimals;
if ACurrencySymbol = '?' then ACurrencySymbol := AFormatSettings.CurrencyString;
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';
nfSci:
Result := '##0' + decs + 'E+0';
nfPercentage:
Result := '0' + decs + '%';
nfCurrency,
nfCurrencyRed,
nfCurrencyDash,
nfCurrencyDashRed:
begin
Result := '';
if ACurrencySymbol <> '' then
Result := Format(POS_FMT[cf], ['#,##0' + decs, ACurrencySymbol]) + ';'
+ Format(NEG_FMT[ncf], ['#,##0' + decs, ACurrencySymbol])
else begin
Result := '#,##0' + decs;
case ncf of
0, 14, 15 : Result := Result + ';(#,##0' + decs + ')';
1, 5, 6, 8, 9, 12: Result := Result + ';-#,##0' + decs;
else Result := Result + ';#,##0' + decs + '-';
end;
end;
if ANumberFormat in [nfCurrency, nfCurrencyRed] then begin
Result := Result + ';0' + decs;
if cf in [2,3] then
Result := Format('%s "%s"', [Result, ACurrencySymbol])
else
Result := Format('%s"%s"', [Result, ACurrencySymbol]);
end else
Result := Result + ';-';
end;
end;
end;
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;
function CountDecs(AFormatString: String; ADecChars: TsDecsChars = ['0']): Byte;
var
i: Integer;
begin
Result := 0;
for i:=Length(AFormatString) downto 1 do begin
if AFormatString[i] in ADecChars then inc(Result);
if AFormatString[i] = '.' then exit;
end;
// Comes to this point when there is no decimal separtor.
Result := 0;
end;
{ Formats the number AValue in "scientific" format with the given number of
decimals. "Scientific" is the same as "exponential", but with exponents rounded
to multiples of 3 (like for "kilo" - "Mega" - "Giga" etc.). }
function SciFloat(AValue: Double; ADecimals: Byte): String;
var
m: Double;
ex: Integer;
begin
if AValue = 0 then
Result := '0.0'
else begin
ex := floor(log10(abs(AValue))); // exponent
// round exponent to multiples of 3
ex := (ex div 3) * 3;
if ex < 0 then dec(ex, 3);
m := AValue * Power(10, -ex); // mantisse
Result := Format('%.*fE%d', [ADecimals, m, ex]);
end;
end;
(*
{ Formats the number AValue as a time string according to the format string.
If the hour part is between square brackets it can be greater than 24 hours.
Dto for the minutes or seconds part, with the higher-value part being added
and no longer being shown explicitly.
Example:
AValue = 1:30:02, FormatStr = "[mm]:ss]" --> "90:02" }
function TimeIntervalToString(AValue: TDateTime; AFormatStr: String): String;
var
hrs, mins, secs: Integer;
diff: Double;
h,m,s,z: Word;
ts: String;
fmt: String;
p: Integer;
begin {
fmt := Lowercase(AFormatStr);
p := pos('h]', fmt);
if p > 0 then begin
System.Delete(fmt, 1, p+2);
Result := FormatDateTime(fmt, AValue);
DecodeTime(frac(abs(AValue)), h, m, s, z);
hrs := h + trunc(abs(AValue))*24;
Result := FormatDateTime(fmt, AValue);
end;
for i
p := pos('h
}
ts := DefaultFormatSettings.TimeSeparator;
DecodeTime(frac(abs(AValue)), h, m, s, z);
hrs := h + trunc(abs(AValue))*24;
if z > 499 then inc(s);
if hrs > 0 then
Result := Format('%d%s%.2d%s%.2d', [hrs, ts, m, ts, s])
else
Result := Format('%d%s%.2d', [m, ts, s]);
if AValue < 0.0 then Result := '-' + Result;
end;
*)
{ Creates a "time interval" format string having the first code identifier
in square brackets. }
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;
{******************************************************************************}
{******************************************************************************}
{ Patch for SysUtils.FormatDateTime }
{ Remove when the feature of square brackets in time format masks is in rtl }
{******************************************************************************}
{******************************************************************************}
// Copied from "fpc/rtl/objpas/sysutils/datei.inc"
procedure DateTimeToString(out Result: string; const FormatStr: string; const DateTime: TDateTime; const FormatSettings: TFormatSettings);
var
ResultLen: integer;
ResultBuffer: array[0..255] of char;
ResultCurrent: pchar;
{$IFDEF MSWindows}
isEnable_E_Format : Boolean;
isEnable_G_Format : Boolean;
eastasiainited : boolean;
{$ENDIF MSWindows}
(* This part is in the original code. It is not needed here and avoids a
dependency on the unit Windows.
{$IFDEF MSWindows}
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);
'[': isInterval := true;
']': isInterval := false;
' ', 'C', 'D', 'H', 'M', 'N', 'S', 'T', 'Y','Z' :
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*60 + trunc(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(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 + 60*Hour + 60*24*trunc(DateTime), 0)
else
if Count = 1 then
StoreInt(Minute, 0)
else
StoreInt(Minute, 2);
'S': if isInterval then
StoreInt(Second + Minute*60 + Hour*60*60 + trunc(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;
(* This part is in the original code. It is not needed here and avoids a
dependency on the unit Windows.
{$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;
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;
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 ;
function FormatDateTimeEx(const FormatStr: string; DateTime: TDateTime): string;
begin
DateTimeToString(Result, FormatStr, DateTime, DefaultFormatSettings);
end;
function FormatDateTimeEx(const FormatStr: string; DateTime: TDateTime;
AFormatSettings: TFormatSettings): string;
begin
DateTimeToString(Result, FormatStr, DateTime, AFormatSettings);
end;
end.
Reference in New Issue View Git Blame Copy Permalink