{*******************************************************************************
    TCompoPosition
機能：      MainControlが動いたらそれに追随して
            SubControlが移動する
備考：      D6のLabeledEditを見て作ったけど
            いまいち使い勝手がよくないぞ
            あとSubControlのAnchorsプロパティと
            ぶつかる場合もあるので適当に注意。
修正履歴：  2001/09/03
            2001/09/18  他FormにあるCompoの破棄も感知するために
                        FreeNotificationを追加
*******************************************************************************}
unit CompoPosition;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
  TCompoPosition = class(TComponent)
  private
    FSubControl: TControl;
    FMainControl: TControl;
    FMainOldWndProc: TWndMethod;
    FSubOldWndProc: TWndMethod;
    FMainRectBuffer: TRect;
    procedure MainWndProc(var Message: TMessage);
    procedure SubWndProc(var Message: TMessage);
    procedure SetMainControl(const Value: TControl);
    procedure SetSubControl(const Value: TControl);
    function GetSubCtrlLeftPosition: Integer;
    function GetSubCtrlTopPosition: Integer;
    procedure SetSubCtrlLeftPosition(const Value: Integer);
    procedure SetSubCtrlTopPosition(const Value: Integer);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property MainControl: TControl read FMainControl write SetMainControl;
    property SubControl: TControl read FSubControl write SetSubControl;
    property SubCtrlLeftPosition: Integer read GetSubCtrlLeftPosition write SetSubCtrlLeftPosition;
    property SubCtrlTopPosition: Integer read GetSubCtrlTopPosition write SetSubCtrlTopPosition;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Samples', [TCompoPosition]);
end;

{ TCompoPosition }

var
  FCompoPositionList: TList;

//WindowProcedure
procedure TCompoPosition.MainWndProc(var Message: TMessage);
var
  MoveDistance: TPoint;
//  RelationPoint: TPoint;
begin
  if (FSubControl<>nil) and (FMainControl<>nil) then
  begin
    case Message.Msg of
      WM_MOVE:
      begin
        //メインコントロールの移動距離を求める
        MoveDistance := Point(
          FMainControl.BoundsRect.Left - FMainRectBuffer.Left,
          FMainControl.BoundsRect.Top  - FMainRectBuffer.Top );

        //サブコントロールを移動させる
        with FSubControl do
        BoundsRect :=
          Rect(BoundsRect.Left+  MoveDistance.x,
               BoundsRect.Top +  MoveDistance.y,
               BoundsRect.Right+ MoveDistance.x,
               BoundsRect.Bottom+MoveDistance.y);

        FMainRectBuffer := FMainControl.BoundsRect;
        //移動後のメインコントロールの位置をバッファに保持
        //Exit;
      end;
    else
    end;
  end;

  FMainOldWndProc(Message);
end;

procedure TCompoPosition.SubWndProc(var Message: TMessage);
begin
  FSubOldWndProc(Message);
end;

procedure TCompoPosition.Notification(AComponent: TComponent;
  Operation: TOperation); 
begin
  inherited Notification(AComponent, Operation);

  //コンポーネントが削除されたときのコード
  case Operation of 
    opRemove: 
      begin
        if (Operation = opRemove) and (AComponent = MainControl) then 
          MainControl := nil;
        if (Operation = opRemove) and (AComponent = SubControl) then 
          SubControl := nil;
      end; 
  end; 
end; 

procedure TCompoPosition.SetMainControl(const Value: TControl);
var
  InitialRect: TRect;
  i: Integer;
begin
  if FMainControl <> Value then
  begin
    if Value = nil then
    begin
      if Assigned(FMainControl) then
      begin
        FMainControl.WindowProc := FMainOldWndProc;
      end; //WndProcを戻す

      FMainRectBuffer := InitialRect; //Rectの初期化

    end else
    begin
      //MainとSubは一緒に設定できない
      if FSubControl = Value then
      begin
        raise Exception.Create(
          'SubControlと同じコンポーネントは指定できません');
        Exit;
      end;

      //他のコンポで
      //SubControlとして指定されているものはMain指定できない
      for i:=0 to FCompoPositionList.Count-1 do
      begin
        if TCompoPosition( FCompoPositionList.Items[i] ).SubControl
             = Value then
        begin
          raise Exception.Create(
            '既にSubControlとして登録されています');
          Exit;
        end;
      end;

      if Assigned(FMainControl) then
      begin
        FMainControl.WindowProc := FMainOldWndProc;
      end; //WndProcを戻す

      FMainOldWndProc := Value.WindowProc;
      Value.WindowProc := MainWndProc;
      Value.FreeNotification(Self);

      FMainRectBuffer := Value.BoundsRect;
    end;

    FMainControl := Value;
  end;
end;

procedure TCompoPosition.SetSubControl(const Value: TControl);
var
  i: Integer;
begin
  if FSubControl <> Value then
  begin
    if Value = nil then
    begin
      if Assigned(FSubControl) then
      begin
        FSubControl.WindowProc := FSubOldWndProc;
      end; //WndProcを戻す

    end else
    begin
      //MainとSubは一緒に設定できない
      if FMainControl = Value then
      begin
        raise Exception.Create(
          'MainControlと同じコンポーネントは指定できません');
        Exit;
      end;

      //他のコンポで
      //SubControlとして指定されているものはSub指定できない
      //MainControlとして指定されているものもSub指定できない
      for i:=0 to FCompoPositionList.Count-1 do
      begin
        if TCompoPosition( FCompoPositionList.Items[i] ).SubControl
             = Value then
        begin
          raise Exception.Create(
            '既にSubControlとして登録されています');
          Exit;
        end;
        if TCompoPosition( FCompoPositionList.Items[i] ).MainControl
             = Value then
        begin
          raise Exception.Create(
            '既にMainControlとして登録されています');
          Exit;
        end;
      end;

      if Assigned(FSubControl) then
      begin
        FSubControl.WindowProc := FSubOldWndProc;
      end; //WndProcを戻す

      FSubOldWndProc := Value.WindowProc;
      Value.WindowProc := SubWndProc;
      Value.FreeNotification(Self);
    end;

    FSubControl := Value;
  end;
end;



constructor TCompoPosition.Create(AOwner: TComponent);
begin
  inherited;
  FMainControl := nil;
  FSubControl := nil;

  FCompoPositionList.Add(Self);
end;

destructor TCompoPosition.Destroy;
begin
  if Assigned(FMainControl) then
  begin
    FMainControl.WindowProc := FMainOldWndProc;
  end;

  if Assigned(FSubControl) then
  begin
    FSubControl.WindowProc := FSubOldWndProc;
  end;

  FCompoPositionList.Extract(Self);

  inherited;
end;

{-------------------------------
//  SubCtrlPositionプロパティ
機能:       MainからのSubへのControlの相対位置を
            Set/Getします
備考:
履歴:       2001/09/03
//------------------------------}

function TCompoPosition.GetSubCtrlLeftPosition: Integer;
begin
  if (FMainControl<>nil) and (FSubControl<>nil) then
  begin
    Result := FSubControl.BoundsRect.Left - FMainControl.BoundsRect.Left;
  end else
    Result := 0;
end;

function TCompoPosition.GetSubCtrlTopPosition: Integer;
begin
  if (FMainControl<>nil) and (FSubControl<>nil) then
  begin
    Result := FSubControl.BoundsRect.Top - FMainControl.BoundsRect.Top;
  end else
    Result := 0;
end;

procedure TCompoPosition.SetSubCtrlLeftPosition(const Value: Integer);
begin
  if (FMainControl<>nil) and (FSubControl<>nil) then
  begin
    FSubControl.Left := FMainControl.Left + Value;
  end;
end;

procedure TCompoPosition.SetSubCtrlTopPosition(const Value: Integer);
begin
  if (FMainControl<>nil) and (FSubControl<>nil) then
  begin
    FSubControl.Top := FMainControl.Top + Value;
  end;
end;
//------------------------------



initialization
  FCompoPositionList := TList.Create;

finalization
  FCompoPositionList.Free;

end.