magnetic.pas

下面又是翻译： 韩国人 Silhwan Hyun 改写。 TMagnetic Class 是一个 Delphi 版本的"cMagneticWnd" 类

// unit Magnetic
//
//  TMagnetic object is a Delphi version equivalent of Visual Basic "cMagneticWnd" class
//   written by Emil Weiss.
//  The forms adapting this object snap to each other, and the form defined as Parent
//    form drags its child forms snapped to that, at beging dragged by user.
//  The original "cMagneticWnd" class directly implants hooking code to sub class
//   window message procedure of form, so we do not need to put extra code to sub class
//   at programming Visual Basic application with that.
//  But straight conversioned Delphi object using above method does not work, (There should
//   be some modifications to adjust some differences between Visual Basic and Delphi)
//   and I could not find out solution.
//  So, I decided to use custom message handler which indirectly calls "zSubclass_Proc" of
//   TMagnetic object, for Delphi version.
//  And we should put extra code per each Form unit to define custom message handler to use
//   TMagnetic object.
//
//  Usage :
//
//   A. Define 7 message handlers in Form class definition phrase as follows,
//
//    TAnyForm = class(TForm)
//               .
//               .
//    private
//      { Private declarations }
//               .
//               .
//    public
//      { Public declarations }
//               .
//               .
//      procedure WMEnterSizeMove(var Msg: TMessage); message WM_ENTERSIZEMOVE;
//      procedure WMSizing(var Msg: TMessage); message WM_SIZING;
//      procedure WMMoving(var Msg: TMessage); message WM_MOVING;
//      procedure WMExitSizeMove(var Msg: TMessage); message WM_EXITSIZEMOVE;
//      procedure WMSysCommand(var Msg: TMessage); message WM_SYSCOMMAND;
//      procedure WMCommand(var Msg: TMessage); message WM_COMMAND;
//      procedure WMShowHideWindow(var Msg: TMessage); message WM_WINDOWPOSCHANGED; { for Sub Forms only }
//    end;
//
//
//  B. Define a global variable which will be used a function pointer to the function
//     "Subclass_Proc" in this unit like this,
//
//    MagneticWndProc: TSubClass_Proc;   { TSubClass_Proc is defined in this unit }
//
//
//  C. Write message handling procedures for the messages defined above as follows,
//
//    procedure TAnyForm.WMEnterSizeMove(var Msg: TMessage);
//    var
//      bHandled: Boolean;
//    begin
//      inherited;
//
//      if Assigned(MagneticWndProc) then
//         MagneticWndProc(Self.Handle, WM_ENTERSIZEMOVE, Msg, bHandled);
//    end;
//
//    procedure TAnyForm.WMExitSizeMove(var Msg: TMessage);
//    { Same to above, just change  "if MagneticWndProc(Self.Handle, WM_ENTERSIZEMOVE, ..."
//                           to     "if MagneticWndProc(Self.Handle, WM_EXITSIZEMOVE, .."  }
//
//    procedure TAnyForm.WMSysCommand(var Msg: TMessage);
//    { Same to above, just change  "if MagneticWndProc(Self.Handle, WM_ENTERSIZEMOVE, ..."
//                           to     "if MagneticWndProc(Self.Handle, WM_SYSCOMMAND, .."  }
//    end;
//
//    procedure TAnyForm.WMCommand(var Msg: TMessage);
//    { Same to above, just change  "if MagneticWndProc(Self.Handle, WM_ENTERSIZEMOVE, ..."
//                           to     "if MagneticWndProc(Self.Handle, WM_COMMAND, .."  }
//    end;
//
//    procedure TAnyForm.WMShowHideWindow(var Msg: TMessage);   { for Sub Forms only }
//    { Same to above, just change  "if MagneticWndProc(Self.Handle, WM_ENTERSIZEMOVE, ..."
//                           to     "if MagneticWndProc(Self.Handle, WM_WINDOWPOSCHANGED, .."  }
//    end;
//
//    procedure TAnyForm.WMSizing(var Msg: TMessage);
//    var
//      bHandled: Boolean;
//    begin
//      if not Assigned(MagneticWndProc) then
//         inherited
//      else
//         if MagneticWndProc(Self.Handle, WM_SIZING, Msg, bHandled) then
//         begin
//            if not bHandled then
//               inherited
//         end else
//            inherited;
//    end;
//
//    procedure TAnyForm.WMMoving(var Msg: TMessage);
//    { Same to above, just change  "if MagneticWndProc(Self.Handle, WM_SIZING, ..."
//                           to     "if MagneticWndProc(Self.Handle, WM_MOVING, .."  }
//
//
//  D. Register the forms to be endowed with magnectic effect as below, at Form show
//     procedures.
//
//    if Assigned(MagneticWnd) then
//    begin
//     { p : variable defined as pointer }
//       if MagneticWnd.AddWindow(Self.Handle, 0, p) then                  { for Parent form }
//    // if MagneticWnd.AddWindow(Self.Handle, ParentForm.Handle, p) then  { for Child form }
//          @MagneticWndProc := p;
//    end;
//
//   (note) "Child form" does not mean that it is a child object of "Parent form".
//          "Child form" means only it is subject to be dragged as "Parent form" is
//          moving.
//
//
//  E. Unregister the forms as below, at Form destroy procedures.
//
//    if Assigned(MagneticWnd) then
//       MagneticWnd.RemoveWindow(Self.Handle);   // Stops magnetic effect
//
//
//  F. (for Parent form unit only) Put a sentence to create an instance of TMagnetic object.
//
//  { MagneticWnd is a variable defined in this unit as TMagnetic object. }
//    MagneticWnd := TMagnetic.Create;    // Preferably at form creation procedure
//
//  G. (for Parent form unit only) Put a sentence to release the instance of TMagnetic object.
//
//    MagneticWnd.Free;                   // Preferably at form destroy procedure
//
//  note) You can use a subclssed widnow procedure instead of message handlers.
//        See the units of Demo project.
//
//  Drafter : Emil Weiss
//
//  Rewritten by Silhwan Hyun   ( 04 Dec 2008 )
//


unit Magnetic;

interface

uses
  Windows, SysUtils, Messages;

Type
  PWND_INFO = ^TWND_INFO;
  TWND_INFO = record
    h_wnd      : HWND;
    hWndParent : HWND;
    Glue       : Boolean;
  end;

  TSubClass_Proc = function(lng_hWnd: HWND; uMsg: Integer;
                            var Msg: TMessage; var bHandled: Boolean) : boolean;

  TMagnetic = class
    constructor Create;
    Destructor Destroy; Override;

   private
    FSnapWidth    : integer;
    m_uWndInfo    : array of TWND_INFO;
    m_rcWnd       : array of TRECT;
    m_lWndCount   : Integer;
    m_ptAnchor    : TPOINT;
    m_ptOffset    : TPOINT;
    m_ptCurr      : TPOINT;
    m_ptLast      : TPOINT;

    function  GetSnapWidth: Integer;
    procedure SetSnapWidth(const Value: Integer);
    procedure pvSizeRect(Handle: HWND; var rcWnd: TRECT; lfEdge: Integer);
    procedure pvMoveRect(Handle: HWND; var rcWnd: TRECT);
    procedure pvCheckGlueing;
    function  pvWndsConnected(rcWnd1: TRECT; rcWnd2: TRECT): Boolean;
    function  pvWndGetInfoIndex(Handle: HWND): Integer;
    function  pvWndParentGetInfoIndex(hWndParent: HWND): Integer;
    procedure zSubclass_Proc(lng_hWnd: HWND;
                             uMsg, wParam, lParam: Integer;
                             var lReturn: Integer;
                             var bHandled: Boolean);

   public
    function  AddWindow(Handle: HWND; hWndParent: HWND; var FuncPointer : TSubClass_Proc): Boolean;
    function  RemoveWindow(Handle: HWND): Boolean;
    procedure CheckGlueing;
    property  SnapWidth: Integer read GetSnapWidth write SetSnapWidth;
  end;

Const
  LB_RECT = 16;

Var
  MagneticWnd: TMagnetic;


implementation


function Subclass_Proc(lng_hWnd: HWND;
                       uMsg: Integer;
                       var Msg: TMessage;
                       var bHandled: Boolean) : boolean;
begin
   if Assigned(MagneticWnd) then
   begin
      MagneticWnd.zSubclass_Proc(lng_hWnd, uMsg,
                                 Msg.wParam, Msg.lParam, Msg.Result, bHandled);
      result := true;
   end else
      result := false;
end;

constructor TMagnetic.create;

begin
 // Default snap width
  SnapWidth := 10;

 // Initialize registered number of window
  m_lWndCount := 0;
end;


Destructor TMagnetic.Destroy;
begin
   MagneticWnd := nil;
   
   SetLength(m_uWndInfo, 0);  // not sure this is needed
   SetLength(m_rcWnd, 0);     // not sure this is needed

   inherited;
end;


function TMagnetic.GetSnapWidth: Integer;
begin
  Result := FSnapWidth;
end; 

procedure TMagnetic.SetSnapWidth(const Value: Integer);
begin
  FSnapWidth := Value; 
end;

procedure TMagnetic.zSubclass_Proc(lng_hWnd: HWND;
                                   uMsg, wParam, lParam: Integer;
                                   var lReturn: Integer;
                                   var bHandled: Boolean);
{
Parameters:
   lng_hWnd - The window handle
   uMsg     - The message number
   wParam   - Message related data
   lParam   - Message related data
   lReturn  - Set this variable as per your intentions and requirements, see the MSDN
              documentation or each individual message value.
   bHandled - Set this variable to True in a 'before' callback to prevent the message being
              subsequently processed by the default handler... and if set, an 'after' callback
}

{
Notes:
   If you really know what you're doing, it's possible to change the values of the
   lng_hWnd, uMsg, wParam and lParam parameters in a 'before' callback so that different
   values get passed to the default handler.. and optionaly, the 'after' callback
}
Var
  rcWnd : TRECT;
  lC    : Integer;
  pWINDOWPOS : ^TWINDOWPOS;
begin
    bHandled := false;

    Case uMsg of
        // Size/Move starting
        WM_ENTERSIZEMOVE:
        begin
            // Get Desktop area (as first rectangle)
            SystemParametersInfo(SPI_GETWORKAREA, 0, @m_rcWnd[0], 0);

            // Get rectangles of all handled windows
            For lC := 1 To m_lWndCount do
             begin
                // Window maximized ?
                If (IsZoomed(m_uWndInfo[lC].h_wnd)) Then
                  begin
                    // Take work are rectangle
                    CopyMemory(@m_rcWnd[lC], @m_rcWnd[0], LB_RECT);
                  end Else
                    // Get window rectangle
                    GetWindowRect((m_uWndInfo[lC].h_wnd), m_rcWnd[lC]);

                // Is it our current window ?
                If (m_uWndInfo[lC].h_wnd = lng_hWnd) Then
                  begin
                    // Get anchor-offset
                    GetCursorPos(m_ptAnchor);
                    GetCursorPos(m_ptLast);
                    m_ptOffset.x := m_rcWnd[lC].Left - m_ptLast.x;
                    m_ptOffset.y := m_rcWnd[lC].Top - m_ptLast.y;
                  end;
            end;
         end;
        // Sizing
        WM_SIZING:
         begin
            CopyMemory(@rcWnd, pointer(lParam), LB_RECT);
            pvSizeRect(lng_hWnd, rcWnd, wParam);
            CopyMemory(pointer(lParam), @rcWnd, LB_RECT);

            bHandled := True;
            lReturn := 1;
         end;
        // Moving
        WM_MOVING:
          begin
            CopyMemory(@rcWnd, pointer(lParam), LB_RECT);
            pvMoveRect(lng_hWnd, rcWnd);
            CopyMemory(pointer(lParam), @rcWnd, LB_RECT);

            bHandled := True;
            lReturn := 1;
          end;
        // Size/Move finishing
        WM_EXITSIZEMOVE:
          begin
            pvCheckGlueing;
          end;
        // at after Shown or Hidden window
        WM_WINDOWPOSCHANGED:  // ************** Added
          begin
            pWINDOWPOS := pointer(lParam);
            if ((pWINDOWPOS^.flags and SWP_SHOWWINDOW) = SWP_SHOWWINDOW) or
               ((pWINDOWPOS^.flags and SWP_HIDEWINDOW) = SWP_HIDEWINDOW) then
               pvCheckGlueing;
          end;
        // Special case: *menu* call
        WM_SYSCOMMAND:
          begin
            If (wParam = SC_MINIMIZE) Or (wParam = SC_RESTORE) Then
                pvCheckGlueing;

          end;
        // Special case: *control* call
        WM_COMMAND:
          begin
            pvCheckGlueing;
          end;
    End;
End;


function TMagnetic.AddWindow(Handle: HWND; hWndParent: HWND; var FuncPointer : TSubClass_Proc): Boolean;
Var
  lC : Integer;

begin
    Result := false;  // assume failure
    FuncPointer := nil;
    
    // Already in collection ?
    For lC := 1 To m_lWndCount do
      begin
        If (Handle = m_uWndInfo[lC].h_wnd) Then
          Exit;
      end;

    // Validate windows
    If IsWindow(Handle) And (IsWindow(hWndParent) Or (hWndParent = 0)) Then  //********* Changed
    begin
        // Increase count
        inc(m_lWndCount);

        // Resize arrays
        SetLength(m_uWndInfo, m_lWndCount+1);
        SetLength(m_rcWnd, m_lWndCount+1);

        // Add info
        m_uWndInfo[m_lWndCount].h_wnd := Handle;
        if hWndParent = Handle then      // Parent window is Self window ?       //******** Added
           m_uWndInfo[m_lWndCount].hWndParent := 0  // Then same to "no parent"  //******** Added
        else
           m_uWndInfo[m_lWndCount].hWndParent := hWndParent;

        // Check glueing for first time
        pvCheckGlueing;

        FuncPointer := Subclass_Proc;

        // Success
        Result := True;
    End;
End;


function TMagnetic.RemoveWindow(Handle: HWND): Boolean;
Var
  lc1 : Integer;
  lc2 : Integer;

begin
    Result := false;  // assume failure

    For lc1 := 1 To m_lWndCount do
    begin
        If (Handle = m_uWndInfo[lc1].h_wnd) Then
        begin
            // Move down
            For lc2 := lc1 To (m_lWndCount - 1) do
            begin
                m_uWndInfo[lc2] := m_uWndInfo[lc2 + 1];
            end;

            // Resize arrays
              dec(m_lWndCount);
              SetLength(m_uWndInfo, m_lWndCount+1);
              SetLength(m_rcWnd, m_lWndCount+1);

            // Remove parent relationships
            For lc2 := 1 To m_lWndCount do
            begin
                If (m_uWndInfo[lc2].hWndParent = Handle) Then
                    m_uWndInfo[lc2].hWndParent := 0;