magnetunit.pas

这是一个有 BUG 的磁性窗体的组件／单元

{: (C) Copyright 2003 - All rights reserved.
    Company: BCP Software, www.bcp-software.nl
    Author:  Marco Wobben, [e-mail] }
unit MagnetUnit;

{ To do

  - If snapped to a screen edge, the resizing of the form using the opposite
    border doesn't snap anymore.
  - How does this work in a MDI application. The mainform's edge may not be
    considering it's border.
  - For multimonitor it now switches to snapmode 'near'. This should only be the
    case for the aligning monitor borders and not for the outermost borders.

  History

  ** 18 September 2003 **
    Fix:
      Thanks to George Boudouris.
    Behaviour:
      Snapping Magnet1 to M2 clustered ok.
      Snapping this new cluster from M1 to M3 didn't cluster M3...
    Routines Changed:
      ClusterSnapList
}

interface

{ $ DEFINE CODESITE}

uses
  Forms, Messages, Windows, Classes, Controls;

type
  TSnapOption = (soInScreen, soMagnet, soInMainForm);
  TSnapOptions = set of TSnapOption;

  TSnapBorder = (sbInner, sbOuter, sbNear);

  TMagnet = class(TComponent)
  private
    FActive: boolean;
    FClientInstance,
      FPrevClientProc: TFarProc;
    FRange: integer;
    FSnapOptions: TSnapOptions;
    FDragStart: TRect;
    FDragging: Boolean;
    FCluster: TList;
    FSnapList: TList;
    FEnableClustering: Boolean;
    FAutoSnap: boolean;
    FClusterSnapping: Boolean;
    FImmediateCluster: boolean;
    FOldArea: TRect;
    FGroupIndex: integer;
    FClusterIndex: integer;
    procedure ClientWndProc(var Message: TMessage);
    procedure SetActive(const Value: boolean);
    procedure SetRange(const Value: integer);
    procedure SetSnapOptions(const Value: TSnapOptions);
    function SnapToRect(var aLeft, aTop: integer; const aWidth, aHeight:
      integer;
      aRect: TRect; aBorder: TSnapBorder): boolean;
    function GetInCluster: Boolean;
    procedure SetEnableClustering(const Value: Boolean);
    procedure UnCluster;
    procedure ReCluster(NewCluster: TList);
    procedure SetAutoSnap(const Value: boolean);
    procedure SetClusterSnapping(const Value: Boolean);
    procedure ClusterSnapList;
    procedure AdjustCluster(Delta: TPoint);
    procedure SetImmediateCluster(const Value: boolean);
    procedure SetGroupIndex(const Value: integer);
    procedure SetClusterIndex(const Value: integer);
  protected
    function Form: TCustomForm;

    function Area: TRect;
    function Center: TPoint;

    procedure WindowPosChanging(var aPos: TPoint; const W, H: integer; Sizing: Boolean = False); virtual;
    procedure WindowSizeChanging(var aRect: TRect); virtual;
    procedure ApplyDeltaPos(aDelta: TPoint);

    procedure AppendCluster(aCluster: TList);
    procedure RemoveFromCluster(aMagnet: TMagnet);
    property Cluster: TList read FCluster;
  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;

    {: Returns true if this is the magnet being dragged by a mouse cursor. }
    property Dragging: Boolean read FDragging;
    {: Returns true if this magnet is part of a cluster. }
    property InCluster: Boolean read GetInCluster;

  published
    {: Activate the magnet by setting Active to true. }
    property Active: boolean read FActive write SetActive default false;
    {: This will enable the magnet to snap to objects specified in the
       SnapOptions unless CTRL is pressed. If set to false it requires CTRL
       to be pressed to enable snapping. }
    property AutoSnap: boolean read FAutoSnap write SetAutoSnap default true;
    {: The groupindex is used to let all magnets with the same groupindex
       respond to each other. }
    property GroupIndex: integer read FGroupIndex write SetGroupIndex default 0;
    {: The clusterindex is a number which if clustering is enabled only works
       on magnets with the same clusterindex. }
    property ClusterIndex: integer read FClusterIndex write SetClusterIndex default 0;
    {: The distance to other objects at which this object will snap. }
    property Range: integer read FRange write SetRange default 15;
    {: Specifies at which objects this magnet will snap.
       soInScreen: snap on the screen edge and make sure the magnet remains inside.
       soMagnet: snap to other magnets.
       soInMainForm: similar to soInScreen, but in this case the application mainform sets the edge.
         (soInMainForm allows the magnet to leave the mainform if the mainform is dragged) }
    property SnapOptions: TSnapOptions read FSnapOptions write SetSnapOptions
      default [soInScreen, soMagnet];
    {: Set this to true to maintain the snapped magnets in a cluster while this
       magnet (or other) is being dragged. }
    property EnableClustering: Boolean read FEnableClustering write
      SetEnableClustering default true;
    {: ClusterSnapping exends the snapping behaviour accross all magnet edges in
       the cluster. }
    property ClusterSnapping: Boolean read FClusterSnapping write
      SetClusterSnapping default true;
    {: This option is default false, once set to true the snapping automatically
       clusters the magnets snapped to and does not wait until snapping is
       completed by releasing the mouse. }
    property ImmediateCluster: boolean read FImmediateCluster
      write SetImmediateCluster default false;
  end;

{: This grows or shrinks the rectangle on all sides with the specified number.
   Passing (5,5,10,10) and 1 will result in (4,4,11,11)
   Passing (5,5,10,10) and -1 will result in (6,6,9,9) }
function GrowRect(aRect: TRect; Grow: integer): TRect;
{: This function returns the surface in pixels. }
function RectArea(aRect: TRect): integer;
{: Returns true if the rectangles are aligned
  (meaning not overlapping and not a pixel space in between) }
function RectAligned(R1, R2: TRect): boolean;
{: Returns true if rectangles are overlapping and false if not. }
function RectOverlap(R1, R2: TRect): boolean;

{: Return the magnet instance in the owner component list or return nil if
   not found. }
function FindMagnet(aOwner: TComponent): TMagnet;
{: Return the magnet instance in the owner component list or returns a new
   instance if not found. }
function GetMagnet(aOwner: TComponent): TMagnet;

{: Sets the autosnap property of all magnets with the specified GroupIndex. }
procedure SetAutoSnapAllMagnets(aAutoSnap: boolean; aGroupIndex: integer);

implementation

uses
  {$IFDEF CODESITE} CsIntf, {$ENDIF}
  SysUtils, Types;

var
  ActiveMagnets: TList;
  AllMagnets: TList;

procedure SetAutoSnapAllMagnets(aAutoSnap: boolean; aGroupIndex: integer);
var
  i: integer;
begin
  for i:=0 to AllMagnets.Count-1 do
    with TMagnet(AllMagnets[i]) do
      if (GroupIndex = aGroupIndex) then
        AutoSnap := aAutoSnap;
end;

function FindMagnet(aOwner: TComponent): TMagnet;
var
  i: integer;
begin
  Result := nil;
  for i := 0 to aOwner.ComponentCount - 1 do
    if aOwner.Components[i] is TMagnet then
    begin
      Result := TMagnet(aOwner.Components[i]);
      Exit;
    end;
end;

function GetMagnet(aOwner: TComponent): TMagnet;
begin
  Result := FindMagnet(aOwner);
  if not Assigned(Result) then
    Result := TMagnet.Create(aOwner);
end;

function GrowRect(aRect: TRect; Grow: integer): TRect;
begin
  Result.Left := aRect.Left - Grow;
  Result.Top := aRect.Top - Grow;
  Result.Right := aRect.Right + Grow;
  Result.Bottom := aRect.Bottom + Grow;
  if IsRectEmpty(aRect) then
    FillChar(Result, SizeOf(Result), #0);
end;

function RectArea(aRect: TRect): integer;
begin
  if IsRectEmpty(aRect) then
    Result := 0
  else
    Result := (aRect.Right - aRect.Left) * (aRect.Bottom - aRect.Top);
end;

function RectAligned(R1, R2: TRect): boolean;
var
  Tmp: TRect;
begin
  Result :=
    not IntersectRect(Tmp, R1, R2) and
    IntersectRect(Tmp, GrowRect(R1, 1), R2);
end;

function RectOverlap(R1, R2: TRect): boolean;
var
  Tmp: TRect;
begin
  Result := IntersectRect(Tmp, R1, R2) and not IsRectEmpty(Tmp);
end;

{ TMagnet }

procedure TMagnet.ApplyDeltaPos(aDelta: TPoint);
var
  R: TRect;
begin
  R := Area;
  OffsetRect(R, aDelta.X, aDelta.Y);
  Form.SetBounds(
    R.Left,
    R.Top,
    R.Right - R.Left,
    R.Bottom - R.Top);
end;

procedure TMagnet.ClientWndProc(var Message: TMessage);
var
  R: TRect;
  P: TPoint;
begin
  with Message do
  begin
    case Msg of
      WM_ENTERSIZEMOVE:
        begin
          FOldArea := Area;
          FDragStart := Area;
          FDragging := True;
        end;
      WM_EXITSIZEMOVE:
        begin
          ClusterSnapList;
          FOldArea := Area;
          FDragging := False;
        end;
      WM_WINDOWPOSCHANGING:
        with TWmWindowPosChanging(Message).WindowPos^ do
        begin
          FSnapList.Clear;
          if ((GetKeyState(VK_CONTROL) and $F0 = 0) xor (not AutoSnap)) and
            (Dragging) then
          begin
            if (cx <> Area.Right-Area.Left) or (cy <> Area.Bottom-Area.Top) and
              (flags and SWP_NOSIZE = 0) then
            begin
              R := Rect(x,y,x+cx,y+cy);
              // {$IFDEF CODESITE}CodeSite.SendRect('SIZE',R);{$ENDIF}
              WindowSizeChanging(R);
              FDragStart := R;
              x := R.Left;
              y := R.Top;
              cx := R.Right-R.Left;
              cy := R.Bottom-R.Top;
            end
            else
            if (flags and SWP_NOMOVE = 0) then
            begin
              P := Point(x, y);
              // {$IFDEF CODESITE}CodeSite.SendRect('MOVE',Rect(x,y,x+cx,y+cy));{$ENDIF}
              WindowPosChanging(P, cx, cy);
              AdjustCluster(
                Point(
                  P.X - FDragStart.Left,
                  P.Y - FDragSTart.Top));
              FDragStart := Rect(P.X, P.Y, P.X+cx, P.Y+cy);
              x := P.x;
              y := P.y;
            end;
            if FImmediateCluster then
              ClusterSnapList;
            // the window message is handled
            Result := 1;
          end
          else
          begin
            if Dragging and InCluster then
              UnCluster;
          end;
        end;
      WM_DESTROY:
        Active := False;
    end;

    if (Result = 0) then
      Result := CallWindowProc(FPrevClientProc, Form.Handle, Msg, wParam,
        lParam);
  end;
end;

constructor TMagnet.Create(aOwner: TComponent);
begin
  if not (aOwner is TCustomForm) then
    raise EComponentError.Create(ClassName + '.Owner must be a TForm');

  if Assigned(FindMagnet(aOwner)) then
    raise EComponentError.Create(ClassName +
      ' can occur only once in a TForm');

  inherited Create(aOwner);

  FActive := False;
  FAutoSnap := True;
  FRange := 15;
  FSnapOptions := [soInScreen, soMagnet];
  FDragging := False;

  FCluster := TList.Create;
  FCluster.Add(Self);

  FSnapList := TList.Create;

  FEnableClustering := True;
  FClusterSnapping := True;
  FImmediateCluster := False;

  FGroupIndex := 0;
  FClusterIndex := 0;

  AllMagnets.Add(Self);
end;

destructor TMagnet.Destroy;
begin
  AllMagnets.Extract(Self);

  Active := False;
  FCluster.Free;
  FSnapList.Free;
  inherited;
end;

function TMagnet.Form: TCustomForm;
begin
  Result := TCustomForm(Owner);
end;

function TMagnet.GetInCluster: Boolean;
begin
  Result := (FCluster.Count > 1);
end;

procedure TMagnet.AppendCluster(aCluster: TList);
var
  i: integer;
begin
  if (EnableClustering) then
    for i := 0 to aCluster.Count - 1 do
      if (FCluster.IndexOf(aCluster[i]) < 0) and
        (TMagnet(aCluster[i]).EnableClustering) then
      begin
        FCluster.Add(aCluster[i]);
      end;
end;

procedure TMagnet.SetActive(const Value: boolean);
begin
  if (Active <> Value) then
  begin
    if Value then
    begin
      // hook into the Form to receive the WM_WINDOWPOSCHANGING
      FClientInstance := MakeObjectInstance(ClientWndProc);
      FPrevClientProc := Pointer(GetWindowLong(Form.Handle, GWL_WNDPROC));
      SetWindowLong(Form.Handle, GWL_WNDPROC, Integer(FClientInstance));

      ActiveMagnets.Add(Self);
    end
    else
    begin
      if InCluster then
        UnCluster;

      // unhook from the Form to stop reveiving the WM_WINDOWPOSCHANGING
      SetWindowLong(Form.Handle, GWL_WNDPROC, Integer(FPrevClientProc));
      FreeObjectInstance(FClientInstance);

      ActiveMagnets.Extract(Self);
    end;

    FActive := Value;
  end;
end;

procedure TMagnet.SetRange(const Value: integer);
begin
  FRange := Value;
end;

procedure TMagnet.SetSnapOptions(const Value: TSnapOptions);
begin
  if (soInMainForm in Value) and (Form = Application.MainForm) then
    FSnapOptions := Value - [soInMainForm]
  else
    FSnapOptions := Value;
end;

function TMagnet.SnapToRect(var aLeft, aTop: integer;
  const aWidth, aHeight: integer; aRect: TRect; aBorder:
  TSnapBorder): boolean;
var
  ISect, RangeRect: TRect;
begin
  Result := False;

  if (aBorder = sbInner) then
  begin
    // left edge
    if (aLeft < aRect.Left + Range) then
    begin
      aLeft := aRect.Left;
      Result := True;
    end;
    // right edge
    if (aLeft + aWidth + Range > aRect.Right) then
    begin
      aLeft := aRect.Right - aWidth;
      Result := True;
    end;
    // top edge
    if (aTop < aRect.Top + Range) then