frxutils.pas

报表源码 FastReport 3 is new generation of the report generators components. It consists of report engin

{******************************************}
{ }
{ FastReport v3.0 }
{ Various routines }
{ }
{ Copyright (c) 1998-2005 }
{ by Alexander Tzyganenko, }
{ Fast Reports Inc. }
{ }
{******************************************}

unit frxUtils;

interface

{$I frx.inc}

uses
  SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms,
  StdCtrls, Menus, ImgList, ActnList, ComCtrls, frxClass
{$IFDEF Delphi6}
, Variants
{$ENDIF};

function frxFindComponent(Owner:TComponent; const Name:String):TComponent;
procedure frxGetComponents(Owner:TComponent; ClassRef:TClass;
  List:TStrings; Skip:TComponent);
function frxGetFullName(Owner:TComponent; c:TComponent):String;
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 frxRect(ALeft, ATop, ARight, ABottom:Extended):TfrxRect;
function frxPoint(X, Y:Extended):TfrxPoint;
function frxGetBrackedVariable(const Str, OpenBracket, CloseBracket:String;
  var i, j:Integer):String;
procedure frxErrorMsg(const Text:String);
procedure frxFormToRes(Form:TForm);
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);
{$IFNDEF Delphi6}
function Utf8Encode(const WS:WideString):String;
function UTF8Decode(const S:String):WideString;
{$ENDIF}
function HTMLRGBColor(Color:TColor):string;
procedure frxWriteCollection(Collection:TCollection; Writer:TWriter;
  Owner:TfrxComponent);
procedure frxReadCollection(Collection:TCollection; Reader:TReader;
  Owner:TfrxComponent);
function frxCreateTempFile(const TempDir:String):String;

implementation

uses frxXMLSerializer, frxRes, TypInfo;

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
    Result:= o.Owner.Name+'.'+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 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 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: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;

procedure frxErrorMsg(const Text:String);
begin
  Application.MessageBox(PChar(Text), PChar(frxResources.Get('mbError')),
    mb_Ok+mb_IconError);
end;

type
  THackControl = class(TControl);

procedure frxFormToRes(Form:TForm);
var
  f:TFileStream;
  l:TList;
  s:String;

  function QStr(s:String):String;
  begin
    s:= QuotedStr(s);
    Result:= Copy(s, 2, Length(s)-2);
  end;

  procedure EnumControls(Parent:TComponent);
  var
    i:Integer;
    s:String;
  begin
    if (Parent is TForm) and not (Parent = Form) then Exit;
    l.Add(Parent);
    s:= '';
    if Parent.Name<>'' then
    begin
      if (Parent is TMenuItem) and (TMenuItem(Parent).Action = nil) then
      begin
        if TMenuItem(Parent).Caption<>'-' then
          s:= ' '''+Parent.Name+'.Caption='+
            QStr(TMenuItem(Parent).Caption)+'''+#13#10+';
      end
      else if (Parent is TControl) and not (Parent is TCustomComboBox) then
      begin
        if (Trim(THackControl(Parent).Caption)<>'') and
          (TControl(Parent).Action = nil) and not (Parent is TEdit) then
          s:= ' '''+Parent.Name+'.Caption='+
            QStr(THackControl(Parent).Caption)+'''+#13#10+';
        if Trim(THackControl(Parent).Hint)<>'' then
        begin
          if s<>'' then
            s:= s+#13#10;
          s:= s+' '''+Parent.Name+'.Hint='+
            QStr(THackControl(Parent).Hint)+'''+#13#10+';
        end;
      end
      else if Parent is TAction then
      begin
        if TAction(Parent).Caption<>'-' then
          s:= ' '''+Parent.Name+'.Caption='+
            QStr(TAction(Parent).Caption)+'''+#13#10+';
      end;

      if s<>'' then
      begin
        s:= s+#13#10;
        f.Write(s[1], Length(s));
      end;
    end;

    if Parent is TWinControl then
      for i:= 0 to TWinControl(Parent).ControlCount-1 do
        EnumControls(TWinControl(Parent).Controls[i]);

    for i:= 0 to Parent.ComponentCount-1 do
      if l.IndexOf(Parent.Components[i]) =-1 then
        EnumControls(Parent.Components[i]);
  end;

begin
  if FileExists('c:\1.pas') then
    f:= TFileStream.Create('c:\1.pas', fmOpenWrite) else
    f:= TFileStream.Create('c:\1.pas', fmCreate);
  f.Position:= f.Size;
  l:= TList.Create;

  s:= #13#10+' frxResources.Add('''+Form.ClassName+''','+#13#10;
  f.Write(s[1], Length(s));

  EnumControls(Form);

  s:= ' '''');'+#13#10;
  f.Write(s[1], Length(s));

  l.Free;
  f.Free;
end;

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
  img:= TImageList.Create(nil);
  img.Width:= bmp.Width;
  img.Height:= bmp.Height;
  img.AddMasked(bmp, bmp.TransparentColor);
  img.Draw(Canvas, x, y, 0);
  img.Clear;