david
ef415fa856
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.FastReport@9 475b051d-3a53-6940-addd-820bf0cfe0d7
459 lines
12 KiB
ObjectPascal
459 lines
12 KiB
ObjectPascal
|
|
{******************************************}
|
|
{ }
|
|
{ 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> |