aprstore.pas

来自「delphi编程控件」· PAS 代码 · 共 993 行 · 第 1/2 页

unit aprstore;
(*
 COPYRIGHT (c) RSD Software 1997 - 98
 All Rights Reserved.
*)

interface

{$I aclver.inc}

uses Classes, SysUtils, Forms;

type

TAutoPropertiesStore = class;

TAutoObjectStore = class(TCollectionItem)
private
  FStore : TAutoPropertiesStore;
  FComponent : TComponent;
  FStoredProp : TStrings;
  FIsForm : Boolean;

  procedure SetComponent(Value : TComponent);
  procedure SetIsForm(Value : Boolean);
  procedure SetStoredProp(Value : TStrings);
public
  constructor Create(Collection : TCollection); override;
  destructor Destroy; override;
published
  property Component : TComponent read FComponent write SetComponent;
  property IsForm : Boolean read FIsForm write SetIsForm;
  property StoredProp : TStrings read FStoredProp write SetStoredProp;
end;

TAutoObjectStoreClass = class of TAutoObjectStore;

TAutoObjectsStore = class(TCollection)
private
  FStore : TAutoPropertiesStore;

  function GetItem(Index : Integer) : TAutoObjectStore;
  procedure SetItem(Index : Integer; Value : TAutoObjectStore);
protected
  procedure Notification(AComponent: TComponent);
public
  constructor Create(AOwner : TAutoPropertiesStore);
  function Add(AComponent : TComponent) : TAutoObjectStore;
  function IndexOfComponent(AComponent : TComponent) : Integer;
  property Items[Index : Integer] : TAutoObjectStore read GetItem write SetItem; default;
end;

TAutoPropertiesStore = class(TComponent)
private
  FObjectsStore : TAutoObjectsStore;
  FOnBeforeRestore : TNotifyEvent;
  FOnAfterRestore : TNotifyEvent;
  FOnBeforeSave : TNotifyEvent;
  FOnAfterSave : TNotifyEvent;
  FActive : Boolean;
  FBinaryFileName: PString;
  FIniFileName: PString;
  FIniSection: PString;
  FUseRegistry: Boolean;
  FSaved: Boolean;
  FSaveFormDestroy: TNotifyEvent;
  FSaveFormCloseQuery: TCloseQueryEvent;

  function GetBinaryFileName: string;
  function GetIniFileName: string;
  function GetIniSection: string;
  procedure SetBinaryFileName(const Value: string);
  procedure SetIniFileName(const Value: string);
  procedure SetIniSection(const Value: string);
  procedure SetObjectsStore(Value : TAutoObjectsStore);

  procedure RestoreFromRegistry(ASts : TStrings);
  procedure SaveToRegistry(ASts : TStrings);
  procedure RestoreFromIniFile(ASts : TStrings);
  procedure SaveToIniFile(ASts : TStrings);
  procedure RestoreBinaryFromBinFile(AName : String; ASts : TStrings);
  procedure SaveBinaryToBinFile(AName : String; ASts : TStrings);
  procedure SetFormEvents;
  procedure RestoreFormEvents;
  procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  procedure FormDestroy(Sender: TObject);
public
  constructor Create(AOwner : TComponent); override;
  destructor Destroy; override;
  procedure Loaded; override;
  procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  procedure RestoreProperties;
  procedure SaveProperties;
published
  property Active : Boolean read FActive write FActive;
  property BinaryFileName : String read GetBinaryFileName write SetBinaryFileName;
  property IniFileName : String read GetIniFileName write SetIniFileName;
  property IniSection : String read GetIniSection write SetIniSection;
  property Items : TAutoObjectsStore read FObjectsStore write SetObjectsStore;
  property UseRegistry : Boolean read FUseRegistry write FUseRegistry  default False;
  property OnAfterRestore : TNotifyEvent read FOnAfterRestore write FOnAfterRestore;
  property OnAfterSave : TNotifyEvent read FOnAfterSave write FOnAfterSave;
  property OnBeforeRestore : TNotifyEvent read FOnBeforeRestore write FOnBeforeRestore;
  property OnBeforeSave : TNotifyEvent read FOnBeforeSave write FOnBeforeSave;
end;

implementation
uses TypInfo, IniFiles, Registry;

Const
  BeginObjectDecSt = 'object';
  BeginObjectDecL = 6;
  EndObjectDecSt = 'end';
  EndCollectionDecSt = 'end>';
  MaxStringLength = 255;

{TAutoObjectStore}
constructor TAutoObjectStore.Create(Collection : TCollection);
begin
  inherited Create(Collection);
  FStore := TAutoObjectsStore(Collection).FStore;
  FStoredProp := TStringList.Create;
  FIsForm := False;
end;

destructor TAutoObjectStore.Destroy;
begin
  FStoredProp.Free;
  inherited Destroy;
end;

procedure TAutoObjectStore.SetComponent(Value : TComponent);
begin
  if(FComponent <> Value) then begin
    FComponent := Value;
    if(FComponent = Nil) Or Not (csLoading in FStore.ComponentState) then begin
      FStoredProp.Clear;
    end;
  end;
  if (FComponent = FStore.Owner) then FIsForm := True;
end;

procedure TAutoObjectStore.SetIsForm(Value : Boolean);
begin
  if(csLoading in FStore.ComponentState) then begin
    FIsForm := Value;
    if(Value) then Component := FStore.Owner;
  end;
end;

procedure TAutoObjectStore.SetStoredProp(Value : TStrings);
begin
  FStoredProp.Assign(Value);
end;

{TAutoObjectsStore}
constructor TAutoObjectsStore.Create(AOwner : TAutoPropertiesStore);
begin
  inherited Create(TAutoObjectStore);
  FStore := AOwner;
end;

procedure TAutoObjectsStore.Notification(AComponent: TComponent);
Var
  i : Integer;
  item : TAutoObjectStore;
begin
  item := Nil;
  for i := 0 to Count - 1 do
    if(Items[i].FComponent = AComponent) then begin
      item := Items[i];
      break;
    end;
  item.Free;  
end;

function TAutoObjectsStore.Add(AComponent : TComponent) : TAutoObjectStore;
begin
  Result := TAutoObjectStore(inherited Add);
  if(Result <> Nil) then
    Result.Component := AComponent;
end;

function TAutoObjectsStore.IndexOfComponent(AComponent : TComponent) : Integer;
Var
  i : Integer;
begin
  Result := -1;
  for i := 0 to Count - 1 do
    if(Items[i].Component = AComponent) then begin
      Result := i;
      break;
    end;
end;

function TAutoObjectsStore.GetItem(Index : Integer) : TAutoObjectStore;
begin
  Result := TAutoObjectStore(inherited Items[Index]);
end;

procedure TAutoObjectsStore.SetItem(Index : Integer; Value : TAutoObjectStore);
begin
  inherited Items[Index] := Value;
end;


{TAutoPropertiesStore}

constructor TAutoPropertiesStore.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  FObjectsStore := TAutoObjectsStore.Create(self);
  FObjectsStore.FStore := Self;
  FIniFileName := NullStr;
  FIniSection := NullStr;
  FBinaryFileName := NullStr;
end;

destructor TAutoPropertiesStore.Destroy;
begin
  if not (csDesigning in ComponentState) then
    RestoreFormEvents;
  DisposeStr(FIniFileName);
  DisposeStr(FIniSection);
  DisposeStr(FBinaryFileName);
  FObjectsStore.Free;
  inherited Destroy;
end;

procedure TAutoPropertiesStore.Loaded;
var
  Loading: Boolean;
begin
  Loading := csLoading in ComponentState;
  inherited Loaded;
  if not (csDesigning in ComponentState) then begin
    if Loading then SetFormEvents;
    if FActive then RestoreProperties;
  end;
end;

procedure TAutoPropertiesStore.SetFormEvents;
begin
  {$IFDEF DELPHI3_0}
  if(Owner is TCustomForm) then
  {$ELSE}
  if(Owner is TForm) then
  {$ENDIF}
    with TForm(Owner) do begin
      FSaveFormCloseQuery := OnCloseQuery;
      OnCloseQuery := FormCloseQuery;
      FSaveFormDestroy := OnDestroy;
      OnDestroy := FormDestroy;
    end;
  if(Owner is TDataModule) then
    with TDataModule(Owner) do begin
      FSaveFormDestroy := OnDestroy;
      OnDestroy := FormDestroy;
    end;
end;

procedure TAutoPropertiesStore.RestoreFormEvents;
begin
  if (Owner <> nil) And
  {$IFDEF DELPHI3_0}
  (Owner is TCustomForm) then
  {$ELSE}
  (Owner is TForm) then
  {$ENDIF}
  with TForm(Owner) do begin
      OnCloseQuery := FSaveFormCloseQuery;
      OnDestroy := FSaveFormDestroy;
    end;
  if(Owner is TDataModule) then
     TDataModule(Owner).OnDestroy := FSaveFormDestroy;
end;

procedure TAutoPropertiesStore.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  if Assigned(FSaveFormCloseQuery) then FSaveFormCloseQuery(Sender, CanClose);
  if CanClose and Active and (TForm(Owner).Handle <> 0) then
    try
      SaveProperties;
    except
      Application.HandleException(Self);
    end;
end;

procedure TAutoPropertiesStore.FormDestroy(Sender: TObject);
begin
  if Active and not FSaved then begin
    try
      SaveProperties;
    except
      Application.HandleException(Self);
    end;
  end;
  if Assigned(FSaveFormDestroy) then FSaveFormDestroy(Sender);
end;


procedure TAutoPropertiesStore.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if(Operation = opRemove) then
    Items.Notification(AComponent);
end;

function TAutoPropertiesStore.GetBinaryFileName: string;
begin
  Result := FBinaryFileName^;
  if (Result = '') and not (csDesigning in ComponentState) then
    Result := ExtractFileName(ChangeFileExt(Application.ExeName, '.BIN'));
end;

function TAutoPropertiesStore.GetIniFileName: string;
begin
  Result := FIniFileName^;
  if (Result = '') and not (csDesigning in ComponentState) then begin
    if UseRegistry then Result := 'Software\' + ExtractFileName(ChangeFileExt(Application.ExeName, ''))
    else Result := ExtractFileName(ChangeFileExt(Application.ExeName, '.INI'));
  end;
end;

function TAutoPropertiesStore.GetIniSection: string;
begin
  Result := FIniSection^;
  if (Result = '') and not (csDesigning in ComponentState) then
    if(Owner <> Nil) then
      Result := Owner.ClassName
    else Result := self.Name;
end;

procedure TAutoPropertiesStore.SetBinaryFileName(const Value: string);
begin
  AssignStr(FBinaryFileName, Value);
end;

procedure TAutoPropertiesStore.SetIniFileName(const Value: string);
begin
  AssignStr(FIniFileName, Value);
end;

procedure TAutoPropertiesStore.SetIniSection(const Value: string);
begin
  AssignStr(FIniSection, Value);
end;


procedure TAutoPropertiesStore.SetObjectsStore(Value : TAutoObjectsStore);
Var
  i : Integer;
begin
  FObjectsStore.Clear;
  for i := 0 to Value.Count - 1 do begin
    FObjectsStore.Add(Value.Items[i].FComponent);
    FObjectsStore.Items[i].FStoredProp.Assign(Value.Items[i].FStoredProp);
    FObjectsStore.Items[i].FStore := FObjectsStore.Items[i].FStore;
  end;
end;

procedure TAutoPropertiesStore.RestoreProperties;
Var
  a, b : TMemoryStream;
  cmp : TComponent;
  Sts, StsC, StsF, StsCollection : TStrings;
  LinePos, LinePosF : Integer;
  CompNameSt : String;
  Collection : TCollection;


  function ReadComponent(AComponent : TComponent) : TComponent;
  var
    Reader: TReader;
  begin
    Reader := TReader.Create(a, 4096);
    Reader.Root := Owner;
    Reader.Parent := AComponent.GetParentComponent;
    a.ReadResHeader;
    try
      Reader.BeginReferences;
      Reader.ReadSignature;
      Result := Reader.ReadComponent(AComponent);
      Reader.FixupReferences;
    finally
      Reader.EndReferences;
      Reader.Free;
    end;
  end;

  function FindNextCompName : String;
  Var
    St : String;
  begin
    Result := '';
    while((LinePos < Sts.Count) And (Pos('.', Sts[LinePos]) < 1)) do
      Inc(LinePos);
    if(LinePos >= Sts.Count) then exit;
    St := Trim(Copy(Sts[LinePos], 1, (Pos('.', Sts[LinePos]) - 1)));
    if(St = CompNameSt) then
      while((LinePos < Sts.Count) And (Pos('.', Sts[LinePos]) > 1))
      And (CompNameSt = St)do begin
        Inc(LinePos);
        if (LinePos < Sts.Count) then
          St := Trim(Copy(Sts[LinePos], 1, Pos('.', Sts[LinePos]) - 1));
      end;
    if(LinePos < Sts.Count) then
      Result := St;
  end;

  function GetSpaces(Number : Integer) : String;
  Var
    i : Integer;
  begin
    Result := '';
    for i := 1 to Number do
      Result := Result + ' ';
  end;

  function GetFullPropName : String;
  begin
    Result := Copy(StsC[LinePosF], 1, Pos('=', StsC[LinePosF]) - 1);
  end;

  function GetPropValue : String;
  begin
    Result := Copy(StsC[LinePosF], Pos('=', StsC[LinePosF]) + 1, MaxStringLength);
  end;

  procedure RestoreArray(SpaceNumber : Integer);
  Var
    St, St1 : String;
  begin
    St := Copy(StsC[LinePosF], 1, Pos('(', StsC[LinePosF]) - 1);
    StsF.Add(GetSpaces(SpaceNumber) + St + ' = (');
    St1 := St;
    while (LinePosF < StsC.Count) And (St = St1) do begin
      StsF.Add(GetSpaces(SpaceNumber + 2) + GetPropValue);
      Inc(LinePosF);
      if(LinePosF < StsC.Count) And (Pos('(', StsC[LinePosF]) > 0) then
        St1 := Copy(StsC[LinePosF], 1, Pos('(', StsC[LinePosF]) - 1)
      else begin
        St1 := '';
        StsF[StsF.Count - 1] := StsF[StsF.Count - 1] + ')';
      end;
    end;
  end;

  procedure RestoreOrd(SpaceNumber : Integer);
  Var
    St : String;
  begin
    St := StsC[LinePosF];
    if(St[Length(St)] <> '@') then begin
      StsF.Add(GetSpaces(SpaceNumber) + St);
      Inc(LinePosF);
    end else begin
      St := Copy(St, 1, Length(St) - 1);
      StsF.Add(GetSpaces(SpaceNumber) + St);
      Inc(LinePosF);
      St := StsC[LinePosF];
      while (St <> '') And (St[1] = '@') do begin
        St := Copy(St, Pos('=', St) + 1, MaxStringLength);
        StsF.Add(GetSpaces(SpaceNumber + 2) + St);
        Inc(LinePosF);
        if(LinePosF < StsC.Count) then
          St := StsC[LinePosF]
        else St := '';  
      end;
    end;
  end;

  procedure RestoreBinary(SpaceNumber : Integer);
  Var
    St : String;
    bSts : TStringList;
    i : Integer;
  begin
    bSts := TStringList.Create;
    St := GetFullPropName;
    St := Copy(St, 1, Pos('{', St) - 1);
    RestoreBinaryFromBinFile(GetPropValue, bSts);
    StsF.Add(GetSpaces(SpaceNumber) + St + '= {');
    Inc(SpaceNumber, 2);
    for i := 0 to bSts.Count - 1 do
      StsF.Add(GetSpaces(SpaceNumber) + bSts[i]);
    StsF[StsF.Count -1] := StsF[StsF.Count -1] + '}';
    bSts.Free;
    Inc(LinePosF);
  end;


  procedure RestoreCollection(SpaceNumber : Integer; FirstLevelFlag : Boolean);
  Var
    St, St1, St2 : String;
    LastNumber, i : Integer;
  begin