Chip 1998 March/Chip_1998-03_cd.bin/zkuste/delphi/WhiteAnts/CMPNAMES.ZIP/DsgnWrap.pas

Pascal/Delphi Source File | 1997-02-14 | 9.9 KB | 305 lines

{
+----------------------------------------------------------------------------+
|                                      ⌐  ⌐                                  |
|                                    ⌐⌐ ⌐ ⌐ ⌐                                |
|                                 ⌐⌐⌐ ⌐   ⌐  ⌐                               |
|                                 ⌐⌐    ⌐ ⌐   ⌐                              |
|                  ⌐             ⌐⌐     ⌐  ⌐                                 |
|                 ⌐ ⌐            ⌐⌐⌐    ⌐⌐  ⌐                                |
|             ⌐⌐  ⌐  ⌐      ⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐  ⌐                                    |
|            ⌐  ⌐⌐  ⌐⌐      ⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐                                  |
|            ⌐ ⌐⌐⌐ ⌐⌐⌐⌐⌐⌐ ⌐⌐⌐ ⌐   ⌐⌐⌐⌐⌐⌐⌐⌐                                   |
|           ⌐ ⌐⌐ ⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐ ⌐   ⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐      Copyright ⌐ 1996-1997 by:  |
|           ⌐ ⌐⌐⌐⌐⌐⌐ ⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐  ⌐ ⌐⌐⌐⌐⌐ ⌐⌐                                 |
|          ⌐ ⌐⌐⌐⌐⌐⌐⌐   ⌐⌐⌐⌐⌐ ⌐⌐⌐⌐    ⌐⌐ ⌐⌐ ⌐      WHITE ANTS SYSTEMHOUSE BV  |
|         ⌐  ⌐⌐⌐⌐⌐⌐⌐ ⌐⌐⌐ ⌐⌐⌐ ⌐⌐ ⌐       ⌐⌐⌐⌐      Geleen 12                  |
|         ⌐ ⌐⌐⌐⌐⌐⌐⌐    ⌐   ⌐⌐   ⌐⌐⌐       ⌐       8032 GB Zwolle             |
|           ⌐⌐⌐⌐⌐⌐     ⌐            ⌐ ⌐           Netherlands                |
|      ⌐⌐⌐  ⌐⌐⌐⌐⌐      ⌐     ⌐⌐     ⌐  ⌐                                     |
|            ⌐⌐       ⌐              ⌐  ⌐⌐⌐ ⌐     Tel. [phone]      |
|      ⌐              ⌐              ⌐            Fax. [phone]      |
|      ⌐             ⌐               ⌐⌐                                      |
|    ⌐              ⌐                  ⌐⌐         www.whiteants.com          |
|  ⌐⌐              ⌐                     ⌐ ⌐      [e-mail]      |
|                 ⌐                                                          |
+----------------------------------------------------------------------------+
  file     : DsgnWrap
  version  : 1.01
  comment  :
  date     : 14-02-1997
  time     : 13:58:00
  author   : G.Beuze, R.Post
  compiler : Delphi 1.0
+----------------------------------------------------------------------------+
| DISCLAIMER:                                                                |
| THIS SOURCE IS FREEWARE. YOU ARE ALLOWED TO USE IT IN YOUR OWN PROJECTS    |
| WITHOUT ANY RESTRICTIONS, BUT YOU ARE NOT ALLOWED TO SELL IT IN ANY WAY.   |
| THERE IS NO WARRANTY AT ALL - YOU USE IT ON YOUR OWN RISC. WHITE ANTS DOES |
| NOT ASSUME ANY RESPONSIBILITY FOR ANY DAMAGE OR ANY LOOSE OF TIME OR MONEY |
| DUE THE USE OF ANY PART OF THIS SOURCE CODE.                               |
+----------------------------------------------------------------------------+

Description:
}

unit DsgnWrap;
{MMWIN:ENDEXPAND}

interface

uses WinTypes, WinProcs, Messages, Classes, SysUtils, Controls, Forms,
     TypInfo, DsgnIntf;

type
  TNotificationEvent = procedure (Sender: TObject; AComponent: TComponent; Operation:
      TOperation) of object;

  TValidateRenameEvent = procedure (Sender: TObject; AComponent: TComponent; const
      CurName, NewName: string) of object;

  TDesignerDecorator = class (TFormDesigner)
  private
    FDesigner: TFormDesigner;
    FOnNotification: TNotificationEvent;
    FOnUnhookError: TNotifyEvent;
    FOnValidateRename: TValidateRenameEvent;
    FOwnsDesigner: Boolean;
  protected
    function GetDesigner: TFormDesigner;
    function GetIsControl: Boolean;
    procedure SetDesigner(Value: TFormDesigner);
    procedure SetIsControl(Value: Boolean);
    procedure UnhookError;
  public
    constructor Create;
    destructor Destroy; override;
    function CreateMethod(const Name:string;TypeData:PTypeData): TMethod; override;
    function GetMethodName(const Method: TMethod): string; override;
    procedure GetMethods(TypeData: PTypeData; Proc: TGetStrProc); override;
    function GetPrivateDirectory: string; override;
    procedure Hook(aForm: TForm); dynamic;
    function IsDesignMsg(Sender: TControl; var Message: TMessage): Boolean; override;
    function MethodExists(const AName: string): Boolean; override;
    procedure Modified; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure PaintGrid; override;
    procedure RenameMethod(const CurName, NewName: string); override;
    procedure ShowMethod(const Name: string); override;
    procedure Unhook; dynamic;
    procedure ValidateRename(AComponent: TComponent; const CurName, NewName: string);
        override;
    property Designer: TFormDesigner read GetDesigner write SetDesigner;
    property IsControl read GetIsControl write SetIsControl;
    property OnNotification: TNotificationEvent read FOnNotification write
        FOnNotification;
    property OnUnhookError: TNotifyEvent read FOnUnhookError write FOnUnhookError;
    property OnValidateRename: TValidateRenameEvent read FOnValidateRename write
        FOnValidateRename;
    property OwnsDesigner: Boolean read FOwnsDesigner write FOwnsDesigner;
  end;


implementation

{
*********************************** TDesignerDecorator ***********************************
}
constructor TDesignerDecorator.Create;
begin
  inherited Create;
end;

destructor TDesignerDecorator.Destroy;
begin
  Unhook;
  Designer := nil;
  inherited Destroy;
end;

function TDesignerDecorator.CreateMethod(const Name:string;TypeData:PTypeData): TMethod;
begin
  if (Designer = nil) then
    FillChar(Result, SizeOf(Result), 0)
  else
    Result := Designer.CreateMethod(Name, TypeData);
end;

function TDesignerDecorator.GetDesigner: TFormDesigner;
begin
  Result := FDesigner;
end;

function TDesignerDecorator.GetIsControl: Boolean;
begin
  if (Designer = nil) then
    Result := False
  else
    Result := Designer.IsControl;
end;

function TDesignerDecorator.GetMethodName(const Method: TMethod): string;
begin
  if (Designer = nil) then
    Result := ''
  else
    Result := Designer.GetMethodName(Method);
end;

procedure TDesignerDecorator.GetMethods(TypeData: PTypeData; Proc: TGetStrProc);
begin
  if (Designer <> nil) then
    Designer.GetMethods(TypeData, Proc);
end;

function TDesignerDecorator.GetPrivateDirectory: string;
begin
  if (Designer = nil) then
    Result := ''
  else
    Result := Designer.GetPrivateDirectory;
end;

procedure TDesignerDecorator.Hook(aForm: TForm);
begin
  if aForm <> Form then
  begin
    { always unhook first }
    Unhook;
    Form := aForm;
    if Form <> nil then
    begin
      Designer := Form.Designer as TFormDesigner;
      Form.Designer := Self;
    end
    else
      Designer := nil;
  end;
end;

function TDesignerDecorator.IsDesignMsg(Sender: TControl; var Message: TMessage): Boolean;
begin
  if (Designer = nil) then
    Result := False
  else
    Result := Designer.IsDesignMsg(Sender, Message);
end;

function TDesignerDecorator.MethodExists(const AName: string): Boolean;
begin
  if (Designer = nil) then
    Result := False
  else
    Result := Designer.MethodExists(AName);
end;

procedure TDesignerDecorator.Modified;
begin
  if (Designer <> nil) then
    Designer.Modified;
end;

procedure TDesignerDecorator.Notification(AComponent: TComponent; Operation: TOperation);
begin
  if (Designer <> nil) then
    Designer.Notification(AComponent, Operation);
  if Assigned(FOnNotification) then
    FOnNotification(Self, AComponent, Operation);
end;

procedure TDesignerDecorator.PaintGrid;
begin
  if (Designer <> nil) then
    Designer.PaintGrid;
end;

procedure TDesignerDecorator.RenameMethod(const CurName, NewName: string);
begin
  if (Designer <> nil) then
    Designer.RenameMethod(CurName, NewName);
end;

procedure TDesignerDecorator.SetDesigner(Value: TFormDesigner);
begin
  if Value <> FDesigner then
  begin
    if OwnsDesigner then FDesigner.Free;
    FDesigner := Value;
  end;
end;

procedure TDesignerDecorator.SetIsControl(Value: Boolean);
begin
  if Designer <> nil then Designer.IsControl := Value
end;

procedure TDesignerDecorator.ShowMethod(const Name: string);
begin
  if (Designer <> nil) then
    Designer.ShowMethod(Name);
end;

procedure TDesignerDecorator.Unhook;
var
  D: TDesigner;
begin
  { The old form might not be alife anymore: so protect with try except }
  try
    D := nil;
    try
      { Is this decorator linked at all? Test: (Form = nil) <=> (not linked) }
      if (Form <> nil) and (Form.Designer <> nil) then
      begin
        if Form.Designer = Self then { Hooked at first position (=Form) }
          if Designer = nil then
            Form.Designer := nil
          else
            Form.Designer := Designer as TFormDesigner
        else
        { Not at first position (form): iterate along designers }
        begin
          D := Form.Designer;
          while Assigned(D) do
          begin
            if D is TDesignerDecorator then
              if TDesignerDecorator(D).Designer = Self then
              begin
                { Yes! it' us: perform actual unhooking }
                TDesignerDecorator(D).Designer := Designer;
                D := nil;
              end
              else { hook position not found yet, so iterate to the next designer }
                D := TDesignerDecorator(D).Designer
            else { not a decorator designer: so don't know how to iterate further }
              Break;
          end;
        end;
      end;
    finally
      Form := nil;
      Designer := nil;
    end;
    if D <> nil then UnhookError;
  except
    { ignore exceptions }
  end;
end;

procedure TDesignerDecorator.UnhookError;
begin
  if Assigned(FOnUnhookError) then FOnUnhookError(Self);
end;

procedure TDesignerDecorator.ValidateRename(AComponent: TComponent; const CurName,
    NewName: string);
begin
  if (Designer <> nil) then
    Designer.ValidateRename(AComponent, CurName, NewName);
  if Assigned(FOnValidateRename) then
    FOnValidateRename(Self, AComponent, CurName, NewName);
end;


initialization
end.