david
ef415fa856
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.FastReport@9 475b051d-3a53-6940-addd-820bf0cfe0d7
498 lines
12 KiB
ObjectPascal
498 lines
12 KiB
ObjectPascal
|
|
{******************************************}
|
|
{ }
|
|
{ FastReport v3.0 }
|
|
{ Various routines }
|
|
{ }
|
|
{ Copyright (c) 1998-2006 }
|
|
{ by Alexander Tzyganenko, }
|
|
{ Fast Reports Inc. }
|
|
{ }
|
|
{******************************************}
|
|
|
|
unit frxUtils;
|
|
|
|
interface
|
|
|
|
{$I frx.inc}
|
|
|
|
uses
|
|
SysUtils, Windows, Messages, Classes, Graphics, Controls
|
|
{$IFDEF Delphi6}
|
|
, Variants
|
|
{$ENDIF};
|
|
|
|
procedure frxSetCommaText(const Text: String; sl: TStrings; Comma: Char = ';');
|
|
function frxRemoveQuotes(const s: String): String;
|
|
function frxStreamToString(Stream: TStream): String;
|
|
procedure frxStringToStream(const s: String; Stream: TStream);
|
|
function frxStrToFloat(s: String): Extended;
|
|
function frxFloatToStr(d: Extended): String;
|
|
function frxGetBrackedVariable(const Str, OpenBracket, CloseBracket: String;
|
|
var i, j: Integer): String;
|
|
function frxGetBrackedVariableW(const Str, OpenBracket, CloseBracket: WideString;
|
|
var i, j: Integer): WideString;
|
|
function frxIsValidFloat(const Value: string): Boolean;
|
|
procedure frxAssignImages(Bitmap: TBitmap; dx, dy: Integer;
|
|
ImgList1: TImageList; ImgList2: TImageList = nil);
|
|
procedure frxDrawTransparent(Canvas: TCanvas; x, y: Integer; bmp: TBitmap);
|
|
procedure frxDrawGraphic(Canvas: TCanvas; DestRect: TRect; aGraph: TGraphic);
|
|
procedure frxParsePageNumbers(const PageNumbers: String; List: TStrings;
|
|
Total: Integer);
|
|
function HTMLRGBColor(Color: TColor): string;
|
|
function GetAppFileName: String;
|
|
function GetAppPath: String;
|
|
function GetTemporaryFolder: String;
|
|
function GetTempFile: String;
|
|
function frxCreateTempFile(const TempDir: String): String;
|
|
function frFloat2Str(const Value: Extended; const Prec: Integer = 2): String;
|
|
function frxReverseString(const AText: string): string;
|
|
|
|
implementation
|
|
|
|
|
|
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 frxStreamToString(Stream: TStream): String;
|
|
var
|
|
Size: Integer;
|
|
p: PChar;
|
|
begin
|
|
Size := Stream.Size;
|
|
SetLength(Result, Size * 2);
|
|
GetMem(p, Size);
|
|
|
|
Stream.Position := 0;
|
|
Stream.Read(p^, Size);
|
|
|
|
BinToHex(p, @Result[1], Size);
|
|
|
|
FreeMem(p, Size);
|
|
end;
|
|
|
|
procedure frxStringToStream(const s: String; Stream: TStream);
|
|
var
|
|
Size: Integer;
|
|
p: PChar;
|
|
begin
|
|
Size := Length(s) div 2;
|
|
GetMem(p, Size);
|
|
|
|
HexToBin(@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
|
|
if s[i] in [',', '.'] then
|
|
s[i] := DecimalSeparator;
|
|
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 frxGetBrackedVariable(const Str, OpenBracket, CloseBracket: String;
|
|
var i, j: Integer): String;
|
|
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;
|
|
|
|
type
|
|
THackControl = class(TControl);
|
|
|
|
function frxIsValidFloat(const Value: string): Boolean;
|
|
begin
|
|
Result := True;
|
|
try
|
|
frxStrToFloat(Value);
|
|
except
|
|
Result := False;
|
|
end;
|
|
end;
|
|
|
|
procedure frxAssignImages(Bitmap: TBitmap; dx, dy: Integer;
|
|
ImgList1: TImageList; ImgList2: TImageList = nil);
|
|
var
|
|
b: TBitmap;
|
|
x, y: Integer;
|
|
Done: Boolean;
|
|
|
|
procedure ReplaceWhite;
|
|
var
|
|
i, j: Integer;
|
|
begin
|
|
with b.Canvas do
|
|
for i := 0 to dx - 1 do
|
|
for j := 0 to dy - 1 do
|
|
if Pixels[i, j] = clWhite then
|
|
Pixels[i, j] := $E0E0E0;
|
|
end;
|
|
|
|
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
|
|
Inc(x, dx);
|
|
b.Canvas.CopyRect(Rect(0, 0, dx, dy), Bitmap.Canvas, Rect(x, y, x + dx, y + dy));
|
|
ReplaceWhite;
|
|
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 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 DrawBitmap(aCanvas: TCanvas; Dest: TRect; Bitmap: TBitmap);
|
|
var
|
|
Info: PBitmapInfo;
|
|
HInfo: HGLOBAL;
|
|
InfoSize: DWord;
|
|
Image: Pointer;
|
|
HImage: HGLOBAL;
|
|
ImageSize: DWord;
|
|
begin
|
|
with Bitmap do
|
|
begin
|
|
GetDIBSizes(Handle, InfoSize, ImageSize);
|
|
HInfo := GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE, InfoSize);
|
|
Info := PBitmapInfo(GlobalLock(HInfo));
|
|
try
|
|
HImage := GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE, ImageSize);
|
|
Image := Pointer(GlobalLock(HImage));
|
|
try
|
|
GetDIB(Handle, Palette, Info^, Image^);
|
|
SetStretchBltMode(ACanvas.Handle, STRETCH_HALFTONE);
|
|
with Info^.bmiHeader do
|
|
StretchDIBits(aCanvas.Handle, Dest.Left, Dest.Top,
|
|
Dest.RIght - Dest.Left, Dest.Bottom - Dest.Top,
|
|
0, 0, biWidth, biHeight, Image, Info^, DIB_RGB_COLORS, SRCCOPY);
|
|
finally
|
|
GlobalUnlock(HImage);
|
|
GlobalFree(HImage);
|
|
end;
|
|
finally
|
|
GlobalUnlock(HInfo);
|
|
GlobalFree(HInfo);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure frxDrawGraphic(Canvas: TCanvas; DestRect: TRect; aGraph: TGraphic);
|
|
var
|
|
Bitmap: TBitmap;
|
|
begin
|
|
if aGraph is TMetaFile then
|
|
Canvas.StretchDraw(DestRect, aGraph)
|
|
else
|
|
begin
|
|
Bitmap := TBitmap.Create;
|
|
try
|
|
Bitmap.Width := aGraph.Width;
|
|
Bitmap.Height := aGraph.Height;
|
|
Bitmap.PixelFormat := pf32Bit;
|
|
Bitmap.Canvas.Draw(0, 0, aGraph);
|
|
DrawBitmap(Canvas, DestRect, Bitmap);
|
|
finally
|
|
Bitmap.Free;
|
|
end;
|
|
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;
|
|
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
|
|
if (n1 > 0) and (n1 <= Total) then
|
|
List.Add(IntToStr(n1));
|
|
Inc(n1);
|
|
end
|
|
else
|
|
if (n2 > 0) and (n2 <= Total) then
|
|
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 HTMLRGBColor(Color: TColor): string;
|
|
var
|
|
TheRgbValue : TColorRef;
|
|
begin
|
|
TheRgbValue := ColorToRGB(Color);
|
|
Result := '#' + Format('%.2x%.2x%.2x', [GetRValue(TheRGBValue), GetGValue(TheRGBValue), GetBValue(TheRGBValue)]);
|
|
end;
|
|
|
|
function GetTemporaryFolder: String;
|
|
var
|
|
Path: String;
|
|
begin
|
|
Setlength(Path, MAX_PATH);
|
|
SetLength(Path, GetTempPath(MAX_PATH, @Path[1]));
|
|
Result := StrPas(@Path[1]);
|
|
end;
|
|
|
|
function GetTempFile: String;
|
|
var
|
|
Path: String;
|
|
FileName: String;
|
|
begin
|
|
SetLength(Path, MAX_PATH);
|
|
SetLength(Path, GetTempPath(MAX_PATH, @Path[1]));
|
|
SetLength(FileName, MAX_PATH);
|
|
GetTempFileName(@Path[1], PChar('fr'), 0, @FileName[1]);
|
|
Result := StrPas(@FileName[1]);
|
|
end;
|
|
|
|
function frxCreateTempFile(const TempDir: String): String;
|
|
var
|
|
Path: String;
|
|
FileName: String;
|
|
begin
|
|
Path := TempDir;
|
|
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]);
|
|
Result := StrPas(@FileName[1]);
|
|
end;
|
|
|
|
function GetAppFileName: String;
|
|
var
|
|
fName: String;
|
|
nsize: cardinal;
|
|
begin
|
|
nsize := MAX_PATH;
|
|
SetLength(fName,nsize);
|
|
SetLength(fName, GetModuleFileName(hinstance, pchar(fName), nsize));
|
|
Result := fName;
|
|
end;
|
|
|
|
function GetAppPath: String;
|
|
begin
|
|
Result := ExtractFilePath(GetAppFileName);
|
|
end;
|
|
|
|
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;
|
|
|
|
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;
|
|
|
|
|
|
end.
|
|
|
|
|
|
//<censored> |