frxformutils.pas

报表控件。FastReport 是非常强大的报表控件

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

unit frxFormUtils;

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 frxCommonErrorHandler(Report: TfrxReport; const Text: String);
procedure frxErrorMsg(const Text: String);
function frxConfirmMsg(const Text: String; Buttons: Integer): Integer;
procedure frxFormToRes(Form: TForm);
function frxRect(ALeft, ATop, ARight, ABottom: Extended): TfrxRect;
function frxPoint(X, Y: Extended): TfrxPoint;
procedure frxWriteCollection(Collection: TCollection; Writer: TWriter;
  Owner: TfrxComponent);
procedure frxReadCollection(Collection: TCollection; Reader: TReader;
  Owner: TfrxComponent);

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 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;

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 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;

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) 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:
          DoStrProp;

        tkVariant:
          DoVariantProp;
      end;
    end;

  finally
    FreeMem(PropList, PropCount * SizeOf(PPropInfo));
  end;
end;

procedure frxWriteCollection(Collection: TCollection; Writer: TWriter;
  Owner: TfrxComponent);
var
  i, l: Integer;
  xs: TfrxXMLSerializer;
  s: String;
  vt: TValueType;
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;
        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;
      end;
    finally
      Writer.WriteListEnd;
      xs.Free;
    end;
  end
  else
  begin
    { called from Delphi streamer }
    Writer.WriteCollection(Collection);
  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;
        s := Reader.ReadString;
        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;

end.


//<censored>