Delphi/FastReport_2022_VCL
Delphi/FastReport_2022_VCL
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
e6303fc1c0
FastReport_2022_VCL/LibD28/frxUtils.pas

1857 lines
49 KiB
ObjectPascal
Raw Normal View History

Inicijalizacija
2024-01-01 16:13:08 +01:00
{******************************************}
{ }
{ FastReport VCL }
{ Various routines }
{ }
{ Copyright (c) 1998-2021 }
{ by Fast Reports Inc. }
{ }
{******************************************}
/// <summary>
/// The unit contains additional helper function used by other FastReports
/// units like type conversions, CRC calculation, image draw and others.
/// </summary>
unit frxUtils;
interface
{$I frx.inc}
uses
SysUtils, {$IFNDEF FPC}Windows, Messages,{$ENDIF}
Classes, Graphics, Controls, Forms,
StdCtrls, Menus, ImgList, ActnList, ComCtrls, frxClass, frxXML, frxCollections
{$IFDEF FPC}
,LCLType, LCLIntf, LazHelper, DateUtils
{$IFDEF LCLGTK2}, Printers{$ENDIF}
{$ENDIF}
{$IFDEF DELPHI16}
, System.UITypes
{$ENDIF}
;
type
{$IFNDEF FPC}
/// <summary>
/// This class used to override standard behaviour of metafile draw
/// function. By default metafile size includes bottom and right bounds, so
/// the real size of metafile is increased by 1. Default draw function in
/// VCL tries to compensate it and decreases right and bottom bounds by 1
/// in draw method. This doesn't work because PlayEnhMetaFile stretches
/// output. As a result output may lose 1 pixel in width and that's very
/// critical for outputs like barcodes lines.
/// </summary>
TfrxMetafile = class(TMetafile)
protected
procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
end;
{$ELSE}
TfrxMetafile = class(TMetafile);
{$ENDIF}
TfrxRectArea = class
public
X, Y, X1, Y1: Extended;
constructor Create(c: TfrxComponent); overload;
constructor Create(Left, Top, Right, Bottom: Extended); overload;
function InterceptsX(a: TfrxRectArea): Boolean;
function InterceptsY(a: TfrxRectArea): Boolean;
function InterceptX(a: TfrxRectArea): TfrxRectArea;
function InterceptY(a: TfrxRectArea): TfrxRectArea;
function Max(x1, x2: Extended): Extended;
function Min(x1, x2: Extended): Extended;
end;
procedure frxParseDilimitedText(aList: TStrings; aText: String; aDelimiter: Char);
/// <summary>
/// Searches for a component on owner by name.
/// </summary>
/// <param name="Owner">
/// Owner component.
/// </param>
/// <param name="Name">
/// Name of the searched component.
/// </param>
function frxFindComponent(Owner: TComponent; const Name: String): TComponent;
/// <summary>
/// Fills list with all found component in application with class type
/// specified in ClassRef parameter. <br />
/// </summary>
/// <param name="Owner">
/// Components owner.
/// </param>
/// <param name="ClassRef">
/// Class reference to search for.
/// </param>
/// <param name="List">
/// Out list parameter.
/// </param>
/// <param name="Skip">
/// Component to skip.
/// </param>
procedure frxGetComponents(Owner: TComponent; ClassRef: TClass;
List: TStrings; Skip: TComponent);
/// <summary>
/// Returns full name of the component includes full sequences of owners
/// delimired by '.' sign.
/// </summary>
/// <param name="Owner">
/// Owner component.
/// </param>
/// <param name="c">
/// Component reference.
/// </param>
function frxGetFullName(Owner: TComponent; c: TComponent): String;
procedure frxSetCommaText(const Text: String; sl: TStrings; Comma: Char = ';');
function frxRemoveQuotes(const s: String): String;
/// <summary>
/// Converts stream bytes to hex string representation.
/// </summary>
/// <param name="Stream">
/// Reference to stream.
/// </param>
/// <returns>
/// Hex string.
/// </returns>
function frxStreamToString(Stream: TStream): String;
/// <summary>
/// Converts hex string representation to stream bytes and writes them to
/// stream.
/// </summary>
/// <param name="s">
/// String with hex representation of bytes.
/// </param>
/// <param name="Stream">
/// Destination stream.
/// </param>
procedure frxStringToStream(const s: String; Stream: TStream);
function frxStringToHex(const Buffer: WideString): String;
function frxHexToString(const Buffer: String): WideString;
function frxDecToBinBytes(d: Longint): string;
function frxStrToFloat(s: String): Extended;
function frxFloatToStr(d: Extended): String;
function frxRect(ALeft, ATop, ARight, ABottom: Extended): TfrxRect;
function frxPoint(X, Y: Extended): TfrxPoint;
function frxGetBrackedVariable(const Str, OpenBracket, CloseBracket: AnsiString;
var i, j: Integer): AnsiString;
function frxGetBrackedVariableW(const Str, OpenBracket, CloseBracket: WideString;
var i, j: Integer): WideString;
procedure frxCommonErrorHandler(Report: TfrxReport; const Text: String);
procedure frxErrorMsg(const Text: String);
procedure frxInfoMsg(const Text: String);
function frxConfirmMsg(const Text: String; Buttons: Integer): Integer;
function frxIsValidFloat(const Value: string): Boolean;
procedure frxAssignImages(Bitmap: TBitmap; dx, dy: Integer;
ImgList1: TImageList; ImgList2: TImageList = nil);
procedure frxDrawIcon(ImgList: TCustomImageList; aBitmap: TBitmap; IconIndex: Integer; BgColor: TColor = clNone);
procedure frxDrawTransparent(Canvas: TCanvas; x, y: Integer; bmp: TBitmap);
procedure frxDrawCheckBox(Canvas: TCanvas; ARect: TRect; aCheckColor: TColor; aFrameColor: TColor; bIsChecked: Boolean);
procedure frxDrawArrow(Canvas: TCanvas; aRect: TRect; aColor: TColor; bVertical: Boolean = True; bMirrored: Boolean = False);
procedure frxDrawArrows(Canvas: TCanvas; aRect: TRect; aColor: TColor; bVertical: Boolean = True; bMirrored: Boolean = False; LineWidth: Integer = 2; LineGap: Integer = 2; Gap: Integer = 3; Count: Integer = 2);
procedure frxParsePageNumbers(const PageNumbers: String; List: TStrings;
Total: Integer);
function ColorText(Color: TColor) : String;
function FFColorText(Color: TColor) : String;
function HTMLRGBColor(Color: TColor): string;
procedure frxWriteCollection(Collection: TCollection; Writer: TWriter; Owner: TfrxComponent); overload;
procedure frxReadCollection(Collection: TCollection; Reader: TReader; Owner: TfrxComponent); overload;
procedure frxWriteCollection(Collection: TCollection; const Name: String; Item: TfrxXmlItem; Owner: TfrxComponent; aAncestor: TfrxCollection); overload;
procedure frxReadCollection(Collection: TCollection; Item: TfrxXmlItem; Owner: TfrxComponent; aAncestor: TfrxCollection); overload;
procedure frxWriteProperties(Instance: TPersistent; Writer: TWriter; Owner: TfrxComponent);
procedure frxReadProperties(Instance: TPersistent; Reader: TReader; Owner: TfrxComponent);
function GetAppFileName: String;
function GetAppPath: String;
function GetTemporaryFolder: String;
function GetTempFile: String;
function frxCreateTempFile(const TempDir: String): String;
{$IFNDEF Delphi7}
function frFloat2Str(const Value: Extended; const Prec: Integer = 2): String;
{$ELSE}
function frFloat2Str(const Value: Extended; const Prec: Integer = 2; const Sep: Char = '.'): String;
{$ENDIF}
function frxReverseString(const AText: string): string;
function frxStreamCRC32(Stream: TStream): Cardinal;
function frxUnixPath2WinPath(const Path: string): string;
{$IFNDEF Delphi6}
function DirectoryExists(const Name: string): Boolean;
{$ENDIF}
{$IFNDEF Delphi7}
function PosEx(const SubStr, S: string; Offset: Cardinal = 1): Integer;
{$ENDIF}
{lcl widgetsets don't like too many Repaint calls, so we use
update for them, Delphi isn't disturbed}
procedure frxUpdateControl(AControl: TWinControl;
const ARepaint: Boolean = {$IFDEF NONWINFPC}False{$ELSE}True{$ENDIF});
procedure GetDisplayScale(DevHandle: THandle; IsPrinterHandle: Boolean; var aScaleX, aScaleY: Extended);
procedure TransparentFillRect(aDC: HDC; Left, Top, Right, Bottom: Integer;
Color: TColor);
function IfStr(Flag: Boolean; const sTrue: string; sFalse: string = ''): string;
function IfInt(Flag: Boolean; const iTrue: integer; iFalse: integer = 0): integer;
function IfReal(Flag: Boolean; const rTrue: Extended; rFalse: Extended = 0.0): Extended;
function IfColor(Flag: Boolean; const cTrue: TColor; cFalse: TColor = clNone): TColor;
function GetStr(const Id: string): string;
function frxFloatDiff(const Val1, Val2: Extended): Boolean;
procedure ScaleBitmap(aBitmap: TBitmap; aScreenPPI: Integer);
function frxSetBkMode(C: TCanvas; bkMode : Integer): Integer;
procedure ChangeGlyphColor(Index: Integer; Color: TColor);
function DateTimeToUTC(DateTime: TDateTime): TDateTime;
type
TByteDinArray = array of Byte;
TWordDinArray = array of Word;
TLongWordDinArray = array of LongWord;
TIntegerDinArray = array of Integer;
const
PageBGName = '_pagebackground';
function IsPageBG(Obj: TfrxComponent): Boolean;
implementation
uses frxXMLSerializer, frxRes, Types, TypInfo, Dialogs;
function IsPageBG(Obj: TfrxComponent): Boolean;
begin
Result := (Obj is TfrxPictureView) and (Obj.Name = PageBGName);
end;
procedure ScaleBitmap(aBitmap: TBitmap; aScreenPPI: Integer);
var
tempBitmap: TBitmap;
begin
if aScreenPPI <= frx_DefaultPPI then Exit;
tempBitmap := TBitmap.Create;
try
tempBitmap.Width := Round(aBitmap.Width * aScreenPPI / frx_DefaultPPI);
tempBitmap.Height := Round(aBitmap.Height * aScreenPPI / frx_DefaultPPI);
tempBitmap.Canvas.StretchDraw(Rect(0, 0, tempBitmap.Width,
tempBitmap.Height), aBitmap);
aBitmap.Assign(tempBitmap);
finally
tempBitmap.Free;
end;
end;
function frxSetBkMode(C: TCanvas; bkMode : Integer): Integer;
begin
{$IFDEF LCLGTK2}
if (not (C is TPrinterCanvas)) then
{$ENDIF}
result := SetBkMode(C.Handle, bkMode);
end;
function frxFloatDiff(const Val1, Val2: Extended): Boolean;
begin
Result := Abs(Val1 - Val2) > 1e-4;
end;
procedure TransparentFillRect(aDC: HDC; Left, Top, Right, Bottom: Integer;
Color: TColor);
const
ChessBrush: array [0 .. 7] of Word = ($AA, $55, $AA, $55, $AA, $55, $AA, $55);
var
aSaveState: Integer;
aBitmap: HBITMAP;
aBrush: HBRUSH;
OldBrush, OldPen: HPEN;
begin
aSaveState := SaveDC(aDC);
aBitmap := CreateBitmap(8, 8, 1, 1, @ChessBrush);
try
aBrush := CreatePatternBrush(aBitmap);
finally
DeleteObject(aBitmap);
end;
OldBrush := SelectObject(aDC, aBrush);
OldPen := SelectObject(aDC, GetStockObject(NULL_PEN));
try
SetROP2(aDC, R2_MASKPEN);
SetBkColor(aDC, RGB(255, 255, 255));
SetTextColor(aDC, RGB(0, 0, 0));
Rectangle(aDC, Left, Top, Right, Bottom);
SetROP2(aDC, R2_MERGEPEN);
SetBkColor(aDC, RGB(0, 0, 0));
SetTextColor(aDC, Color);
Rectangle(aDC, Left, Top, Right, Bottom);
finally
SelectObject(aDC, OldBrush);
SelectObject(aDC, OldPen);
DeleteObject(aBrush);
RestoreDC(aDC, aSaveState);
end;
end;
{ TfrxRectArea }
constructor TfrxRectArea.Create(c: TfrxComponent);
begin
Create(c.AbsLeft, c.AbsTop, c.AbsLeft + c.Width, c.AbsTop + c.Height);
end;
constructor TfrxRectArea.Create(Left, Top, Right, Bottom: Extended);
begin
X := Left;
Y := Top;
X1 := Right;
Y1 := Bottom;
end;
function TfrxRectArea.InterceptsX(a: TfrxRectArea): Boolean;
begin
Result := False;
if (a.X < X1 - 1e-4) and (a.X1 > X + 1e-4) then
Result := True;
end;
function TfrxRectArea.InterceptsY(a: TfrxRectArea): Boolean;
begin
Result := False;
if (a.Y < Y1 - 1e-4) and (a.Y1 > Y + 1e-4) then
Result := True;
end;
function TfrxRectArea.InterceptX(a: TfrxRectArea): TfrxRectArea;
begin
Result := nil;
if InterceptsX(a) then
Result := TfrxRectArea.Create(Max(a.X, X), 0, Min(a.X1, X1), 0);
end;
function TfrxRectArea.InterceptY(a: TfrxRectArea): TfrxRectArea;
begin
Result := nil;
if InterceptsY(a) then
Result := TfrxRectArea.Create(0, Max(a.Y, Y), 0, Min(a.Y1, Y1));
end;
function TfrxRectArea.Max(x1, x2: Extended): Extended;
begin
if x1 > x2 then
Result := x1
else
Result := x2;
end;
function TfrxRectArea.Min(x1, x2: Extended): Extended;
begin
if x1 < x2 then
Result := x1
else
Result := x2;
end;
const
CRCTable: array [0..255] of Cardinal = (
0000000000, 1996959894, 3993919788, 2567524794,
0124634137, 1886057615, 3915621685, 2657392035,
0249268274, 2044508324, 3772115230, 2547177864,
0162941995, 2125561021, 3887607047, 2428444049,
0498536548, 1789927666, 4089016648, 2227061214,
0450548861, 1843258603, 4107580753, 2211677639,
0325883990, 1684777152, 4251122042, 2321926636,
0335633487, 1661365465, 4195302755, 2366115317,
0997073096, 1281953886, 3579855332, 2724688242,
1006888145, 1258607687, 3524101629, 2768942443,
0901097722, 1119000684, 3686517206, 2898065728,
0853044451, 1172266101, 3705015759, 2882616665,
0651767980, 1373503546, 3369554304, 3218104598,
0565507253, 1454621731, 3485111705, 3099436303,
0671266974, 1594198024, 3322730930, 2970347812,
0795835527, 1483230225, 3244367275, 3060149565,
1994146192, 0031158534, 2563907772, 4023717930,
1907459465, 0112637215, 2680153253, 3904427059,
2013776290, 0251722036, 2517215374, 3775830040,
2137656763, 0141376813, 2439277719, 3865271297,
1802195444, 0476864866, 2238001368, 4066508878,
1812370925, 0453092731, 2181625025, 4111451223,
1706088902, 0314042704, 2344532202, 4240017532,
1658658271, 0366619977, 2362670323, 4224994405,
1303535960, 0984961486, 2747007092, 3569037538,
1256170817, 1037604311, 2765210733, 3554079995,
1131014506, 0879679996, 2909243462, 3663771856,
1141124467, 0855842277, 2852801631, 3708648649,
1342533948, 0654459306, 3188396048, 3373015174,
1466479909, 0544179635, 3110523913, 3462522015,
1591671054, 0702138776, 2966460450, 3352799412,
1504918807, 0783551873, 3082640443, 3233442989,
3988292384, 2596254646, 0062317068, 1957810842,
3939845945, 2647816111, 0081470997, 1943803523,
3814918930, 2489596804, 0225274430, 2053790376,
3826175755, 2466906013, 0167816743, 2097651377,
4027552580, 2265490386, 0503444072, 1762050814,
4150417245, 2154129355, 0426522225, 1852507879,
4275313526, 2312317920, 0282753626, 1742555852,
4189708143, 2394877945, 0397917763, 1622183637,
3604390888, 2714866558, 0953729732, 1340076626,
3518719985, 2797360999, 1068828381, 1219638859,
3624741850, 2936675148, 0906185462, 1090812512,
3747672003, 2825379669, 0829329135, 1181335161,
3412177804, 3160834842, 0628085408, 1382605366,
3423369109, 3138078467, 0570562233, 1426400815,
3317316542, 2998733608, 0733239954, 1555261956,
3268935591, 3050360625, 0752459403, 1541320221,
2607071920, 3965973030, 1969922972, 0040735498,
2617837225, 3943577151, 1913087877, 0083908371,
2512341634, 3803740692, 2075208622, 0213261112,
2463272603, 3855990285, 2094854071, 0198958881,
2262029012, 4057260610, 1759359992, 0534414190,
2176718541, 4139329115, 1873836001, 0414664567,
2282248934, 4279200368, 1711684554, 0285281116,
2405801727, 4167216745, 1634467795, 0376229701,
2685067896, 3608007406, 1308918612, 0956543938,
2808555105, 3495958263, 1231636301, 1047427035,
2932959818, 3654703836, 1088359270, 0936918000,
2847714899, 3736837829, 1202900863, 0817233897,
3183342108, 3401237130, 1404277552, 0615818150,
3134207493, 3453421203, 1423857449, 0601450431,
3009837614, 3294710456, 1567103746, 0711928724,
3020668471, 3272380065, 1510334235, 0755167117);
function frxStreamCRC32(Stream: TStream): Cardinal;
var
OldPos: Integer;
b: Byte;
c: Cardinal;
begin
OldPos := Stream.Position;
Stream.Position := 0;
c := $ffffffff;
while Stream.Position < Stream.Size do
begin
Stream.Read(b,1);
c := CrcTable[(c xor Cardinal(b)) and $ff] xor (c shr 8);
end;
Stream.Position := OldPos;
Result := c xor $ffffffff;
end;
procedure frxParseDilimitedText(aList: TStrings; aText: String; aDelimiter: Char);
var
sLen, i, sPos: Integer;
begin
aList.Clear;
if (aText = '') or (aText = aDelimiter) then Exit;
aList.BeginUpdate;
try
sLen := Length(aText);
i := 1;
sPos := 1;
while i <= sLen do
begin
if (aText[i] = aDelimiter) and (sPos < i) or ((i = sLen) and (aList.Count > 0)) then
begin
if i = sLen then Inc(i);
aList.Add(Copy(aText, sPos, i - sPos));
sPos := i + 1;
end;
inc(i);
end;
finally
aList.EndUpdate;
end;
end;
function frxFindComponent(Owner: TComponent; const Name: String): TComponent;
var
n: Integer;
s1, s2: String;
begin
Result := nil;
n := Pos('.', Name);
try
if n = 0 then
begin
if Owner <> nil then
Result := Owner.FindComponent(Name);
if (Result = nil) and (Owner is TfrxReport) and (Owner.Owner <> nil) then
Result := Owner.Owner.FindComponent(Name);
end
else
begin
s1 := Copy(Name, 1, n - 1); // module name
s2 := Copy(Name, n + 1, 255); // component name
Owner := FindGlobalComponent(s1);
if Owner <> nil then
begin
n := Pos('.', s2);
if n <> 0 then // frame name - Delphi5
begin
s1 := Copy(s2, 1, n - 1);
s2 := Copy(s2, n + 1, 255);
Owner := Owner.FindComponent(s1);
if Owner <> nil then
Result := Owner.FindComponent(s2);
end
else
Result := Owner.FindComponent(s2);
end;
end;
except
on Exception do
raise EClassNotFound.Create('Missing ' + Name);
end;
end;
{$HINTS OFF}
procedure frxGetComponents(Owner: TComponent; ClassRef: TClass;
List: TStrings; Skip: TComponent);
var
i, j: Integer;
procedure EnumComponents(f: TComponent);
var
i: Integer;
c: TComponent;
begin
{$IFDEF Delphi5}
if f is TForm then
for i := 0 to TForm(f).ControlCount - 1 do
begin
c := TForm(f).Controls[i];
if c is TFrame then
EnumComponents(c);
end;
{$ENDIF}
for i := 0 to f.ComponentCount - 1 do
begin
c := f.Components[i];
if (c <> Skip) and (c is ClassRef) then
List.AddObject(frxGetFullName(Owner, c), c);
end;
end;
begin
List.Clear;
if Owner is TfrxReport then
EnumComponents(Owner);
for i := 0 to Screen.FormCount - 1 do
EnumComponents(Screen.Forms[i]);
for i := 0 to Screen.DataModuleCount - 1 do
EnumComponents(Screen.DataModules[i]);
{$IFDEF Delphi6} // D6 bugfix
with Screen do
for i := 0 to CustomFormCount - 1 do
with CustomForms[i] do
if (ClassName = 'TDataModuleForm') then
for j := 0 to ComponentCount - 1 do
begin
if (Components[j] is TDataModule) then
EnumComponents(Components[j]);
end;
{$ENDIF}
end;
{$HINTS ON}
function frxGetFullName(Owner: TComponent; c: TComponent): String;
var
o: TComponent;
begin
Result := '';
if c = nil then Exit;
o := c.Owner;
if (o = nil) or (o = Owner) or ((Owner is TfrxReport) and (o = Owner.Owner)) then
Result := c.Name
else if ((o is TForm) or (o is TDataModule)) then
Result := o.Name + '.' + c.Name
{$IFDEF Delphi5}
else if o is TFrame then
if o.Owner <> nil then
Result := o.Owner.Name + '.' + c.Owner.Name + '.' + c.Name
else
Result := c.Owner.Name + '.' + c.Name
{$ENDIF}
end;
procedure frxSetCommaText(const Text: String; sl: TStrings; Comma: Char = ';');
var
i: Integer;
function ExtractCommaName(s: string; var Pos: Integer): string;
var
i: Integer;
begin
i := Pos;
while (i <= Length(s)) and (s[i] <> Comma) do Inc(i);
Result := Copy(s, Pos, i - Pos);
if (i <= Length(s)) and (s[i] = Comma) then Inc(i);
Pos := i;
end;
begin
i := 1;
sl.Clear;
while i <= Length(Text) do
sl.Add(ExtractCommaName(Text, i));
end;
function frxRemoveQuotes(const s: String): String;
begin
if (Length(s) > 2) and (s[1] = '"') and (s[Length(s)] = '"') then
Result := Copy(s, 2, Length(s) - 2) else
Result := s;
end;
function frxStringToHex(const Buffer: WideString): String;
begin
SetLength(Result, Length(Buffer) * 4);
BinToHex(PAnsiChar(PWideChar(Buffer)), PChar(Result), Length(Buffer) * 2);
end;
function frxHexToString(const Buffer: String): WideString;
begin
SetLength(Result, Length(Buffer) div 4);
HexToBin(PChar(Buffer), PAnsiChar(PWideChar(Result)), Length(Result) * 2);
end;
function frxDecToBinBytes(d: Longint): string;
var
x: Integer;
bin: string;
begin
bin := '';
for x := 1 to 8 * SizeOf(d) do
begin
if Odd(d) then bin := '1' + bin
else
bin := '0' + bin;
d := d shr 1;
end;
Delete(bin, 1, 8 * ((Pos('1', bin) - 1) div 8));
Result := bin;
end;
function frxStreamToString(Stream: TStream): String;
var
Size: Integer;
{$IFDEF Delphi12}
p: PAnsiChar;
{$ELSE}
p: PChar;
{$ENDIF}
begin
Size := Stream.Size;
SetLength(Result, Size * 2);
GetMem(p, Size);
Stream.Position := 0;
Stream.Read(p^, Size);
BinToHex(p, PChar(@Result[1]), Size);
FreeMem(p, Size);
end;
procedure frxStringToStream(const s: String; Stream: TStream);
var
Size: Integer;
{$IFDEF Delphi12}
p: PAnsiChar;
{$ELSE}
p: PChar;
{$ENDIF}
begin
Size := Length(s) div 2;
GetMem(p, Size);
HexToBin(PChar(@s[1]), p, Size * 2);
Stream.Position := 0;
Stream.Write(p^, Size);
FreeMem(p, Size);
end;
function frxStrToFloat(s: String): Extended;
var
i: Integer;
begin
for i := 1 to Length(s) do
{$IFDEF Delphi12}
if CharInSet(s[i], [',', '.']) then
{$ELSE}
if s[i] in [',', '.'] then
{$ENDIF}
{$IFDEF Delphi16}
s[i] := FormatSettings.DecimalSeparator;
{$ELSE}
s[i] := DecimalSeparator;
{$ENDIF}
while Pos(' ', s) <> 0 do
Delete(s, Pos(' ', s), 1);
Result := StrToFloat(s);
end;
function frxFloatToStr(d: Extended): String;
begin
if Int(d) = d then
Result := FloatToStr(d) else
Result := Format('%2.2f', [d]);
end;
function frxRect(ALeft, ATop, ARight, ABottom: Extended): TfrxRect;
begin
with Result do
begin
Left := ALeft;
Top := ATop;
Right := ARight;
Bottom := ABottom;
end;
end;
function frxPoint(X, Y: Extended): TfrxPoint;
begin
Result.X := X;
Result.Y := Y;
end;
function frxGetBrackedVariable(const Str, OpenBracket, CloseBracket: AnsiString;
var i, j: Integer): AnsiString;
var
c: Integer;
fl1, fl2: Boolean;
begin
Result := '';
j := i;
fl1 := True;
fl2 := True;
c := 0;
if (Str = '') or (j > Length(Str)) then Exit;
Dec(j);
repeat
Inc(j);
if isDBCSLeadByte(Byte(Str[j])) then { if DBCS then skip 2 bytes }
Inc(j, 2);
if fl1 and fl2 then
if Copy(Str, j, Length(OpenBracket)) = OpenBracket then
begin
if c = 0 then i := j;
Inc(c);
end
else if Copy(Str, j, Length(CloseBracket)) = CloseBracket then
Dec(c);
if fl1 then
if Str[j] = '"' then fl2 := not fl2;
if fl2 then
if Str[j] = '''' then fl1 := not fl1;
until (c = 0) or (j >= Length(Str));
Result := Copy(Str, i + Length(OpenBracket), j - i - Length(OpenBracket));
if i <> j then
Inc(j, Length(CloseBracket) - 1);
end;
function frxGetBrackedVariableW(const Str, OpenBracket, CloseBracket: WideString;
var i, j: Integer): WideString;
var
c: Integer;
fl1, fl2: Boolean;
begin
Result := '';
j := i;
fl1 := True;
fl2 := True;
c := 0;
if (Str = '') or (j > Length(Str)) then Exit;
Dec(j);
repeat
Inc(j);
if fl1 and fl2 then
if Copy(Str, j, Length(OpenBracket)) = OpenBracket then
begin
if c = 0 then i := j;
Inc(c);
end
else if Copy(Str, j, Length(CloseBracket)) = CloseBracket then
Dec(c);
if fl1 then
if Str[j] = '"' then fl2 := not fl2;
if fl2 then
if Str[j] = '''' then fl1 := not fl1;
until (c = 0) or (j >= Length(Str));
Result := Copy(Str, i + Length(OpenBracket), j - i - Length(OpenBracket));
if i <> j then
Inc(j, Length(CloseBracket) - 1);
end;
procedure frxCommonErrorHandler(Report: TfrxReport; const Text: String);
var
e: Exception;
begin
case Report.EngineOptions.NewSilentMode of
simMessageBoxes: frxErrorMsg(Text);
simReThrow: begin e := Exception.Create(Text); raise e; end;
end;
end;
procedure frxErrorMsg(const Text: String);
begin
Application.MessageBox(PChar(Text), PChar(frxResources.Get('mbError')),
mb_Ok + mb_IconError);
end;
function frxConfirmMsg(const Text: String; Buttons: Integer): Integer;
begin
Result := Application.MessageBox(PChar(Text),
PChar(frxResources.Get('mbConfirm')), mb_IconQuestion + Buttons);
end;
procedure frxInfoMsg(const Text: String);
begin
Application.MessageBox(PChar(Text), PChar(frxResources.Get('mbInfo')),
mb_Ok + mb_IconInformation);
end;
function frxIsValidFloat(const Value: string): Boolean;
begin
Result := True;
try
frxStrToFloat(Value);
except
Result := False;
end;
end;
procedure frxMakeDisabledImage(Bitmap: TBitmap);
var
i, j: Integer;
c: TColor;
B, G, R: Integer;
begin
for i := 0 to Bitmap.Width - 1 do
for j := 0 to Bitmap.Height - 1 do
begin
c := Bitmap.Canvas.Pixels[i, j];
r := c and $FF0000 div $10000;
g := c and $FF00 div $100;
b := c and $FF;
c := (r + g + b) div 3;
c := Round(c / 3);
c := c + 150;
if c > 255 then
c := 255;
Bitmap.Canvas.Pixels[i, j] := c * $10000 + c * $100 + c;
end;
end;
procedure frxAssignImages(Bitmap: TBitmap; dx, dy: Integer;
ImgList1: TImageList; ImgList2: TImageList = nil);
var
b: TBitmap;
x, y: Integer;
Done: Boolean;
begin
b := TBitmap.Create;
b.Width := dx;
b.Height := dy;
x := 0; y := 0;
repeat
b.Canvas.CopyRect(Rect(0, 0, dx, dy), Bitmap.Canvas, Rect(x, y, x + dx, y + dy));
Done := y > Bitmap.Height;
if not Done then
begin
ImgList1.AddMasked(b, b.TransparentColor);
if ImgList2 <> nil then
begin
frxMakeDisabledImage(b);
ImgList2.AddMasked(b, b.TransparentColor);
end;
end;
Inc(x, dx);
if x >= Bitmap.Width then
begin
x := 0;
Inc(y, dy);
end;
until Done;
b.Free;
end;
procedure frxDrawIcon(ImgList: TCustomImageList; aBitmap: TBitmap; IconIndex: Integer; BgColor: TColor);
begin
aBitmap.Width := ImgList.Width;
aBitmap.Height := ImgList.Height;
aBitmap.Canvas.Lock;
try
aBitmap.Canvas.Brush.Color := BgColor;
aBitmap.Canvas.FillRect(Rect(0, 0, aBitmap.Width, aBitmap.Height));
finally
aBitmap.Canvas.Unlock;
end;
ImgList.Draw(aBitmap.Canvas, 0, 0, IconIndex);
end;
procedure frxDrawTransparent(Canvas: TCanvas; x, y: Integer; bmp: TBitmap);
var
img: TImageList;
begin
if Assigned(bmp) then
begin
img := TImageList.Create(nil);
try
img.Width := bmp.Width;
img.Height := bmp.Height;
img.AddMasked(bmp, bmp.TransparentColor);
img.Draw(Canvas, x, y, 0);
img.Clear;
finally
img.Free;
end;
end;
end;
procedure frxDrawCheckBox(Canvas: TCanvas; ARect: TRect; aCheckColor: TColor; aFrameColor: TColor; bIsChecked: Boolean);
var
rWidth, rHeight, cx, lWidth: Integer;
lScale: Single;
{ Simplified linear function with slope y=kx+b }
{ we use only 45 and 135 angles tan = 1 and -1 }
{ these angles don't have distortions on draw and have better look at different scales }
begin
with Canvas do
begin
{ we use size of 11:11 as original size and calc scale based on it }
lScale := (ARect.Right - ARect.Left) / 11;
Pen.Color := aFrameColor;
Rectangle(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom);
Pen.Color := aCheckColor;
Brush.Color := aCheckColor;
SetRect(ARect, ARect.Left + Round(1 + lScale), ARect.Top + Round(3 + lScale), ARect.Right - Round(2 + lScale), ARect.Bottom - Round(2 + lScale));
rWidth := ARect.Right - ARect.Left;
rHeight := ARect.Bottom - ARect.Top;
cx := rWidth div 2 - rWidth div 5;
lWidth := Round(2 * lScale);
if lScale > 1 then
Inc(lWidth, Round(lScale));
if bIsChecked then
with ARect do
Polygon([Point(Left + cx, Top + rHeight),
Point(Left, Top + rHeight - cx),
Point(Left, Top + rHeight - cx - lWidth),
Point(Left + cx, Top + rHeight - lWidth),
Point(Left + rWidth, Top + rHeight - (rWidth - cx) - lWidth)
, Point(Left + rWidth, Top + rHeight - (rWidth - cx)),
Point(Left + cx, Top + rHeight)]);
end;
end;
procedure frxDrawArrow(Canvas: TCanvas; aRect: TRect; aColor: TColor; bVertical: Boolean = True; bMirrored: Boolean = False);
var
w, h, dx, dy, td, offx, offy: Integer;
procedure SwapInt(var X, Y: Integer);
var
Tmp: Integer;
begin
Tmp := X;
X := Y;
Y := Tmp;
end;
begin
Canvas.Brush.Color := aColor;
Canvas.Brush.Style := bsSolid;
Canvas.Pen.Color := aColor;
Canvas.Pen.Style := psSolid;
Canvas.Pen.Width := 1;
w := aRect.Right - aRect.Left;
h := aRect.Bottom - aRect.Top;
offx := 0;
offy := 0;
if (w mod 2 = 0) then
offx := -1;
if (h mod 2 = 0) then
offy := -1;
dx := Round((w div 2) * 0.5);
w := w - dx * 2;
w := w - w mod 2;
dy := h div 2 - (w div 2) div 2;
h := w div 2;
if not bVertical then
begin
td := dx;
dx := dy;
dy := td;
end;
Inc(aRect.Left, dx);
Inc(aRect.Top, dy);
Dec(aRect.Right, dx);
Dec(aRect.Bottom, dy);
if bVertical then
begin
OffsetRect(aRect, offx, 0);
if bMirrored then
begin
SwapInt(aRect.Top, aRect.Bottom);
h := -h;
end;
Canvas.Polygon([Point(aRect.Left, aRect.Top), Point(aRect.Left + w div 2,
aRect.Top + h), Point(aRect.Left + w, aRect.Top), Point(aRect.Left,
aRect.Top)])
end
else
begin
OffsetRect(aRect, 0, offy);
if bMirrored then
begin
SwapInt(aRect.Left, aRect.Right);
h := -h;
end;
Canvas.Polygon([Point(aRect.Left, aRect.Top), Point(aRect.Left,
aRect.Top + w), Point(aRect.Left + h, aRect.Top + w div 2),
Point(aRect.Left, aRect.Top)])
end;
end;
procedure frxDrawArrows(Canvas: TCanvas; aRect: TRect; aColor: TColor; bVertical: Boolean; bMirrored: Boolean; LineWidth: Integer; LineGap: Integer; Gap: Integer; Count: Integer);
var
dir, i, offset: Integer;
procedure SwapInt(var X, Y: Integer);
var
Tmp: Integer;
begin
Tmp := X;
X := Y;
Y := Tmp;
end;
procedure SimpleDraw(aRect: TRect);
var
w, h, cx: Integer;
begin
w := aRect.Right - aRect.Left;
h := aRect.Bottom - aRect.Top;
cx := w div 2;
if bMirrored then
begin
if not bVertical then
SwapInt(aRect.Left, aRect.Right)
else
SwapInt(aRect.Top, aRect.Bottom);
end;
with ARect do
begin
if not bVertical then
begin
Canvas.Polygon([Point(Left + w * dir, Top + cx),
Point(Left + (w - cx) * dir, Top), Point(Left + (h - cx) * dir, Top + LineWidth), Point(Left + (h - LineWidth) * dir, Top + cx), Point(Left + w * dir, Top + cx)]);
Canvas.Polygon([Point(Left + h * dir, Top + w - cx),
Point(Left + (h - cx) * dir, Top + w), Point(Left + (h - cx) * dir, Top + w - LineWidth), Point(Left + (h - LineWidth) * dir, Top + w - Abs(cx)), Point(Left + h * dir, Top + w - cx)]);
end
else
begin
Canvas.Polygon([Point(Left + cx, Top + h * dir),
Point(Left, Top + (h - cx) * dir), Point(Left, Top + (h - cx - LineWidth) * dir), Point(Left + cx, Top + (h - LineWidth) * dir), Point(Left + cx, Top + h * dir)]);
Canvas.Polygon([Point(Left + w - cx, Top + (h) * dir),
Point(Left + w, Top + (h - cx) * dir), Point(Left + w, Top + (h - cx - LineWidth) * dir), Point(Left + w - Abs(cx), Top + (h - LineWidth) * dir), Point(Left + w - Abs(cx), Top + (h) * dir)]);
end;
end;
end;
begin
Canvas.Brush.Color := aColor;
Canvas.Brush.Style := bsSolid;
Canvas.Pen.Color := aColor;
Canvas.Pen.Style := psSolid;
Canvas.Pen.Width := 1;
dir := 1;
if bMirrored then
dir := -1;
InflateRect(aRect, -Gap, -Gap);
offset := LineGap * 2 * -dir;
for i := 1 to Count do
begin
SimpleDraw(aRect);
if bVertical then
OffsetRect(aRect, 0, offset)
else
OffsetRect(aRect, offset, 0);
end;
end;
procedure frxParsePageNumbers(const PageNumbers: String; List: TStrings;
Total: Integer);
var
i, j, n1, n2: Integer;
s: String;
IsRange: Boolean;
begin
List.Clear;
s := PageNumbers;
for i := Length(s) downto 1 do
begin
{$IFDEF Delphi12}
if not CharInSet(s[i], ['0', '1'..'9', '-', ',']) then
{$ELSE}
if not (Char(s[i]) in ['0', '1'..'9', '-', ',']) then
{$ENDIF}
Delete(s, i, 1);
end;
{while Pos(' ', s) <> 0 do
Delete(s, Pos(' ', s), 1);}
if s = '' then Exit;
if s[Length(s)] = '-' then
s := s + IntToStr(Total);
s := s + ',';
i := 1; j := 1; n1 := 1;
IsRange := False;
while i <= Length(s) do
begin
if s[i] = ',' then
begin
n2 := StrToInt(Copy(s, j, i - j));
j := i + 1;
if IsRange then
while n1 <= n2 do
begin
List.Add(IntToStr(n1));
Inc(n1);
end
else
List.Add(IntToStr(n2));
IsRange := False;
end
else if s[i] = '-' then
begin
IsRange := True;
n1 := StrToInt(Copy(s, j, i - j));
j := i + 1;
end;
Inc(i);
end;
end;
function ColorText(Color: TColor) : String;
var
TheRgbValue : TColorRef;
begin
TheRgbValue := ColorToRGB(Color);
Result := Format('%.2x%.2x%.2x', [GetRValue(TheRGBValue), GetGValue(TheRGBValue), GetBValue(TheRGBValue)]);
end;
function FFColorText(Color: TColor) : String;
begin
Result := 'FF' + ColorText(Color);
end;
function HTMLRGBColor(Color: TColor): string;
begin
Result := '#' + ColorText(Color);
end;
procedure ConvertOneItem(Item: TCollectionItem; ToAnsi: Boolean);
var
i: Integer;
TypeInfo: PTypeInfo;
PropCount: Integer;
PropList: PPropList;
function Convert(const Value: String): String;
var
i: Integer;
begin
Result := '';
i := 1;
while i <= Length(Value) do
begin
if ToAnsi then
begin
if Value[i] >= #128 then
Result := Result + #1 + Chr(Ord(Value[i]) - 128) else
Result := Result + Value[i];
end
else
begin
if (Value[i] = #1) and (i < Length(Value)) then
begin
Result := Result + Chr(Ord(Value[i + 1]) + 128);
Inc(i);
end
else
Result := Result + Value[i];
end;
Inc(i);
end;
end;
procedure DoStrProp;
var
Value, NewValue: String;
begin
Value := GetStrProp(Item, PropList[i]);
NewValue := Convert(Value);
if Value <> NewValue then
SetStrProp(Item, PropList[i], NewValue);
end;
procedure DoVariantProp;
var
Value: Variant;
begin
Value := GetVariantProp(Item, PropList[i]);
if (TVarData(Value).VType = varString) or (TVarData(Value).VType = varOleStr)
{$IFDEF Delphi12} or (TVarData(Value).VType = varUString){$ENDIF} then
begin
Value := Convert(Value);
SetVariantProp(Item, PropList[i], Value);
end;
end;
begin
TypeInfo := Item.ClassInfo;
PropCount := GetTypeData(TypeInfo).PropCount;
GetMem(PropList, PropCount * SizeOf(PPropInfo));
GetPropInfos(TypeInfo, PropList);
try
for i := 0 to PropCount - 1 do
begin
case PropList[i].PropType^.Kind of
tkString, tkLString, tkWString{$IFDEF FPC}, tkAString{$ENDIF}:
DoStrProp;
tkVariant:
DoVariantProp;
end;
end;
finally
FreeMem(PropList, PropCount * SizeOf(PPropInfo));
end;
end;
procedure frxWriteProperties(Instance: TPersistent; Writer: TWriter; Owner: TfrxComponent);
var
xs: TfrxXMLSerializer;
begin
xs := TfrxXMLSerializer.Create(nil);
try
Writer.WriteString(xs.ObjToXML(Instance));
finally
xs.Free;
end;
end;
procedure frxReadProperties(Instance: TPersistent; Reader: TReader; Owner: TfrxComponent);
var
xs: TfrxXMLSerializer;
begin
xs := TfrxXMLSerializer.Create(nil);
try
xs.XMLToObj(Reader.ReadString, Instance);
finally
xs.Free;
end;
end;
procedure frxWriteCollection(Collection: TCollection; Writer: TWriter;
Owner: TfrxComponent);
var
i: Integer;
xs: TfrxXMLSerializer;
s: String;
{$IFDEF Delphi12}
{$ELSE}
vt: TValueType;
l: Integer;
{$ENDIF}
begin
if Owner.IsWriting then
begin
{ called from SaveToStream }
Writer.WriteListBegin;
xs := TfrxXMLSerializer.Create(nil);
try
xs.Owner := Owner.Report;
for i := 0 to Collection.Count - 1 do
begin
Writer.WriteListBegin;
{$IFDEF Delphi12}
s := {UTF8Encode(}xs.ObjToXML(Collection.Items[i]);
Writer.WriteString(s);
Writer.WriteListEnd;
{$ELSE}
{$IFDEF FPC}
s := {UTF8Encode(}xs.ObjToXML(Collection.Items[i]);
Writer.WriteString(s);
Writer.WriteListEnd;
{$ELSE}
s := xs.ObjToXML(Collection.Items[i]);
vt := vaLString;
Writer.Write(vt, SizeOf(vt));
l := Length(s);
Writer.Write(l, SizeOf(l));
Writer.Write(s[1], l);
Writer.WriteListEnd;
{$ENDIF}
{$ENDIF}
end;
finally
Writer.WriteListEnd;
xs.Free;
end;
end
else
begin
{ called from Delphi streamer }
Writer.WriteCollection(Collection);
end;
end;
procedure frxWriteCollection(Collection: TCollection; const Name: String; Item: TfrxXmlItem; Owner: TfrxComponent; aAncestor: TfrxCollection);
var
i: Integer;
xs: TfrxXMLSerializer;
xi: TfrxXmlItem;
aReport: TfrxReport;
needFree: Boolean;
frxCollection: TfrxCollection;
ItemAnc: TPersistent;
cItem: TfrxCollectionItem;
begin
Item := Item.Add;
Item.Name := Name;
NeedFree := False;
frxCollection := nil;
xs := nil;
ItemAnc := nil;
//Owner.IsAncestor
aReport := Owner.Report;
if aReport <> nil then
xs := TfrxXMLSerializer(aReport.XmlSerializer);
if Collection is TfrxCollection then
frxCollection := TfrxCollection(Collection);
if xs = nil then
begin
xs := TfrxXMLSerializer.Create(nil);
xs.Owner := aReport;
NeedFree := True;
// todo for collection editors, to determinate ancestor
//IsInherite := Owner.IsAncestor and (frxCollection <> nil);
end;
try
for i := 0 to Collection.Count - 1 do
begin
if (frxCollection <> nil) and (aAncestor <> nil) then
begin
ItemAnc := aAncestor.FindByName(TfrxCollectionItem(frxCollection.Items[i]).InheritedName)
end;
xi := Item.Add;
xi.Name := 'item';
if ItemAnc <> nil then
xi.Text := xi.Text + ' InheritedName="' + frxStrToXML(TfrxCollectionItem(ItemAnc).InheritedName) + '"';
xi.Text := xi.Text + xs.ObjToXML(Collection.Items[i], '', ItemAnc);
if Assigned(frxCollection) then
begin
cItem := TfrxCollectionItem(Collection.Items[i]);
if cItem.IsUniqueNameStored then
xi.Text := xi.Text + ' uin="' + IntToStr(cItem.UniqueIndex) + '"';
end;
end;
finally
if NeedFree then
xs.Free;
end;
end;
procedure frxReadCollection(Collection: TCollection; Reader: TReader;
Owner: TfrxComponent);
var
i: Integer;
vt: TValueType;
xs: TfrxXMLSerializer;
s: String;
Item: TCollectionItem;
NeedFree: Boolean;
begin
vt := Reader.ReadValue;
if vt <> vaCollection then
begin
{ called from LoadFromStream }
NeedFree := False;
xs := nil;
if Owner.Report <> nil then
xs := TfrxXMLSerializer(Owner.Report.XMLSerializer);
if xs = nil then
begin
xs := TfrxXMLSerializer.Create(nil);
xs.Owner := Owner.Report;
NeedFree := True;
end;
try
Collection.Clear;
while not Reader.EndOfList do
begin
Reader.ReadListBegin;
Item := Collection.Add;
{$IFDEF Delphi12}
//UTF8Decode()
s := Reader.ReadString;
{$ELSE}
s := Reader.ReadString;
{$ENDIF}
if NeedFree then
xs.ReadPersistentStr(Owner.Report, Item, s)
else
xs.XMLToObj(s, Item);
Reader.ReadListEnd;
end;
finally
Reader.ReadListEnd;
if NeedFree then
xs.Free;
end;
end
else
begin
{ called from Delphi streamer }
Reader.ReadCollection(Collection);
for i := 0 to Collection.Count - 1 do
ConvertOneItem(Collection.Items[i], False);
end;
end;
procedure frxReadCollection(Collection: TCollection; Item: TfrxXmlItem; Owner: TfrxComponent; aAncestor: TfrxCollection);
var
i: Integer;
xs: TfrxXMLSerializer;
ci: TCollectionItem;
ci1: TfrxCollectionItem;
needFree: Boolean;
frxCollection: TfrxCollection;
InheritedName: String;
begin
xs := nil;
frxCollection := nil;
needFree := False;
// use parent serializer if any. We need fixups.
if Owner.Report <> nil then
xs := TfrxXMLSerializer(Owner.Report.XmlSerializer);
if Collection is TfrxCollection then
frxCollection := TfrxCollection(Collection);
if xs = nil then
begin
xs := TfrxXMLSerializer.Create(nil);
xs.Owner := Owner.Report;
needFree := True;
end;
try
if (Owner.IsAncestor) and (frxCollection = nil) then
Collection.Clear;
for i := 0 to Item.Count - 1 do
begin
if Owner.IsAncestor and (frxCollection <> nil) {and (aAncestor <> nil)} then
begin
InheritedName := Item[i].Prop['InheritedName'];
if InheritedName <> '' then
begin
ci1 := frxCollection.FindByName(InheritedName);
if ci1 <> nil then
begin
xs.XMLToObj(Item[i].Text, ci1);
ci1.IsInherited := True;
end;
Continue;
end;
end;
ci := Collection.Add;
xs.XMLToObj(Item[i].Text, ci);
if Assigned(frxCollection) then
begin
ci1 := TfrxCollectionItem(ci);
if ci1.IsUniqueNameStored then
begin
InheritedName := Item[i].Prop['uin'];
if InheritedName <> '' then
ci1.UniqueIndex := StrToInt(InheritedName);
end;
end;
end;
finally
if needFree then
xs.Free;
end;
end;
function GetTemporaryFolder: String;
var
Path: String;
begin
{$IFDEF FPC}
Result := GetTempDir(True);
{$ELSE}
Setlength(Path, MAX_PATH);
SetLength(Path, GetTempPath(MAX_PATH, @Path[1]));
{$IFDEF Delphi12}
Result := StrPas(PWideChar(@Path[1]));
{$ELSE}
Result := StrPas(@Path[1]);
{$ENDIF}
{$ENDIF}
end;
function GetTempFile: String;
var
Path: String;
FileName: String;
begin
{$IFDEF FPC}
Result := GetTempFileName(GetTempDir(True),'');
{$ELSE}
SetLength(Path, MAX_PATH);
SetLength(Path, GetTempPath(MAX_PATH, @Path[1]));
SetLength(FileName, MAX_PATH);
GetTempFileName(@Path[1], PChar('fr'), 0, @FileName[1]);
{$IFDEF Delphi12}
Result := StrPas(PWideChar(@FileName[1]));
{$ELSE}
Result := StrPas(@FileName[1]);
{$ENDIF}
{$ENDIF}
end;
function frxCreateTempFile(const TempDir: String): String;
var
Path: String;
FileName: String;
{$IFDEF FPC}
AFileHandle: THandle;
{$ENDIF}
begin
Path := TempDir;
{$IFDEF FPC}
if (Path <> '') and (Path[Length(Path)] <> PathDelim) then
Path := Path + PathDelim;
Result := GetTempFileName(Path,'fr');
AFileHandle := FileCreate(Result);
if AFileHandle <> -1 then
FileClose(AFileHandle);
{$ELSE}
if (Path <> '') and (Path[Length(Path)] <> '\') then
Path := Path + '\';
SetLength(FileName, MAX_PATH);
if Path = '' then
begin
SetLength(Path, MAX_PATH);
SetLength(Path, GetTempPath(MAX_PATH, @Path[1]));
end
else begin
Path := Path + #0;
SetLength(Path, MAX_PATH);
end;
GetTempFileName(@Path[1], PChar('fr'), 0, @FileName[1]);
{$IFDEF Delphi12}
Result := StrPas(PWideChar(@FileName[1]));
{$ELSE}
Result := StrPas(@FileName[1]);
{$ENDIF}
{$ENDIF}
end;
function GetAppFileName: String;
{$IFNDEF FPC}
var
fName: String;
nsize: cardinal;
{$ENDIF}
begin
{$IFNDEF FPC}
if (IsLibrary) then
begin
nsize := MAX_PATH;
SetLength(fName,nsize);
SetLength(fName, GetModuleFileName(hinstance, pchar(fName), nsize));
Result := fName;
end
else
{$ENDIF}
Result := Application.ExeName;
end;
function GetAppPath: String;
begin
Result := ExtractFilePath(GetAppFileName);
end;
{$IFNDEF Delphi7}
function frFloat2Str(const Value: Extended; const Prec: Integer = 2): String;
var
i: Integer;
IntVal: Integer;
begin
IntVal := Trunc(Value);
if IntVal <> Value then
Result := Format('%.' + IntToStr(Prec)+ 'f', [Value])
else
Result := IntToStr(IntVal);
if DecimalSeparator <> '.' then
begin
i := Pos(DecimalSeparator, Result);
if i > 0 then
Result[i] := '.';
end;
end;
{$ELSE}
function frFloat2Str(const Value: Extended; const Prec: Integer = 2; const Sep: Char = '.'): String;
var
FormatSettings: TFormatSettings;
Buffer: array[0..63] of Char;
begin
FormatSettings.DecimalSeparator := Sep;
FormatSettings.ThousandSeparator := Char(0);
SetString(Result, Buffer, FloatToText(Buffer, Value, fvExtended,
ffFixed, 32, Prec, FormatSettings));
end;
{$ENDIF}
function frxReverseString(const AText: string): string;
var
I: Integer;
P: PChar;
begin
SetLength(Result, Length(AText));
P := PChar(Result);
for I := Length(AText) downto 1 do
begin
P^ := AText[I];
Inc(P);
end;
end;
function ChangeChars(const Str: string; FromChar, ToChar: Char): string;
var
I: Integer;
begin
Result := Str;
for I := 1 to Length(Result) do
if Result[I] = FromChar then
Result[I] := ToChar;
end;
function frxUnixPath2WinPath(const Path: string): string;
begin
Result := ChangeChars(Path, '/', '\');
end;
{$IFNDEF Delphi6}
function DirectoryExists(const Name: string): Boolean;
var
Code: Integer;
begin
Code := GetFileAttributes(PChar(Name));
Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
end;
{$ENDIF}
{$IFNDEF Delphi7}
function PosEx(const SubStr, S: string; Offset: Cardinal = 1): Integer;
var
I,X: Integer;
Len, LenSubStr: Integer;
begin
if Offset = 1 then
Result := Pos(SubStr, S)
else
begin
I := Offset;
LenSubStr := Length(SubStr);
Len := Length(S) - LenSubStr + 1;
while I <= Len do
begin
if S[I] = SubStr[1] then
begin
X := 1;
while (X < LenSubStr) and (S[I + X] = SubStr[X + 1]) do
Inc(X);
if (X = LenSubStr) then
begin
Result := I;
exit;
end;
end;
Inc(I);
end;
Result := 0;
end;
end;
{$ENDIF}
procedure frxUpdateControl(AControl: TWinControl;
const ARepaint: Boolean = {$IFDEF NONWINFPC}False{$ELSE}True{$ENDIF});
begin
{$IFDEF FPC}
if AControl.HandleAllocated then
begin
{$ENDIF}
if ARepaint then
AControl.Repaint
else
AControl.Update;
{$IFDEF FPC}
end;
{$ENDIF}
end;
procedure GetDisplayScale(DevHandle: THandle; IsPrinterHandle: Boolean; var aScaleX, aScaleY: Extended);
{$IFNDEF FPC}
var
DevMode: TDevMode;
{$ENDIF}
begin
aScaleX := GetDeviceCaps(DevHandle, LOGPIXELSX) / 96;
aScaleY := GetDeviceCaps(DevHandle, LOGPIXELSY) / 96;
if (Abs(aScaleX - 1) > 1e-4) and (Abs(aScaleY - 1) > 1e-4) or IsPrinterHandle then
Exit;
// scale factor for non DPI aware applications
// msdn.microsoft.com/en-us/library/windows/desktop/dn469266(v=vs.85).aspx
{$IFNDEF FPC}
ZeroMemory(@DevMode, sizeof(DevMode));
if EnumDisplaySettings(nil, Cardinal(-1{ENUM_CURRENT_SETTINGS MSDN FLAG}), DevMode) then
begin
aScaleX := 1 / (DevMode.dmPelsWidth / GetSystemMetrics(SM_CXSCREEN));
aScaleY := 1 / (DevMode.dmPelsHeight / GetSystemMetrics(SM_CYSCREEN));
end;
{$ENDIF}
end;
function IfStr(Flag: Boolean; const sTrue: string; sFalse: string = ''): string;
begin
if Flag then
Result := sTrue
else
Result := sFalse;
end;
function IfInt(Flag: Boolean; const iTrue: integer; iFalse: integer = 0): integer;
begin
if Flag then
Result := iTrue
else
Result := iFalse;
end;
function IfReal(Flag: Boolean; const rTrue: Extended; rFalse: Extended = 0.0): Extended;
begin
if Flag then
Result := rTrue
else
Result := rFalse;
end;
function IfColor(Flag: Boolean; const cTrue: TColor; cFalse: TColor = clNone): TColor;
begin
if Flag then
Result := cTrue
else
Result := cFalse;
end;
function GetStr(const Id: string): string;
begin
Result := frxResources.Get(Id)
end;
{ TfrxMetafile }
{$IFNDEF FPC}
procedure TfrxMetafile.Draw(ACanvas: TCanvas; const Rect: TRect);
var
MetaPal, OldPal: HPALETTE;
R: TRect;
begin
if Handle = 0 then Exit;
MetaPal := Palette;
OldPal := 0;
if MetaPal <> 0 then
begin
OldPal := SelectPalette(ACanvas.Handle, MetaPal, True);
RealizePalette(ACanvas.Handle);
end;
R := Rect;
PlayEnhMetaFile(ACanvas.Handle, Handle, R);
if MetaPal <> 0 then
SelectPalette(ACanvas.Handle, OldPal, True);
end;
{$ENDIF}
procedure ChangeGlyphColor(Index: Integer; Color: TColor);
var
bmp: TBitmap;
begin
bmp := TBitmap.Create;
bmp.Width := Round(frxDefToolImageWidth * (frxResources.ImagesPPI / 96));
bmp.Height := Round(frxDefToolImageHeight * (frxResources.ImagesPPI / 96));
{$IFDEF FPC}
bmp.TransparentColor := clOlive;
{$ENDIF}
with bmp.Canvas do
begin
Brush.Color := clOlive;
FillRect(Rect(0, 0, bmp.Width, bmp.Height));
end;
frxResources.MainButtonImages.Draw(bmp.Canvas, 0, 0, Index);
with bmp.Canvas do
begin
Brush.Color := Color;
FillRect(Rect(1, bmp.Height - 3, bmp.Width, bmp.Height));
end;
frxResources.MainButtonImages.ReplaceMasked(Index, bmp, bmp.TransparentColor);
bmp.Free;
end;
function DateTimeToUTC(DateTime: TDateTime): TDateTime;
{$IFNDEF FPC}
var SystemTime, LocalSystemTime: TSystemTime;
FileTime, LocalFileTime: TFileTime;
{$ENDIF}
begin
{$IFNDEF FPC}
DateTimeToSystemTime(DateTime, SystemTime);
SystemTimeToFileTime(SystemTime, LocalFileTime);
LocalFileTimeToFileTime(LocalFileTime, FileTime);
FileTimeToSystemTime(FileTime, LocalSystemTime);
Result := SystemTimeToDateTime(LocalSystemTime);
{$ELSE}
Result := LocalTimeToUniversal(DateTime);
{$ENDIF}
end;
end.
Reference in New Issue Copy Permalink