●解説
マウスによるフォームの移動やサイズ調整時に、スクリーン外枠（タスクバーも
含む）にスナップする TForm の例です。

マルチ−フォームの場合は、フォーム外枠にもスナップします。

●使用方法
フォームを２作成して、Form1 の OnShow を設定して、実行させてください。

type
  TForm1 = class(TForm)
    procedure FormShow(Sender: TObject);
  private
    FpntMoveOrg,
    FpntMoveFit     : TPoint; 

    procedure WMSizing(var MSG: Tmessage); message WM_Sizing;
    procedure WMEnterSizeMove(var MSG: Tmessage); message WM_EnterSizeMove;
    procedure WMMoving(var MSG: Tmessage); message WM_Moving;
  public
  end;

const
  ciFittingThreshold = 6;  // スナップ補正の最大量

procedure FormFitSizeToForms(frmTgt: TForm; var rectNew: TRect; iSide: integer);{}
  procedure Sub(const rectTgt: TRect; var rectForm: TRect);
  begin
    if ((rectForm.Bottom + ciFittingThreshold >= rectTgt.Top   ) and
        (rectForm.Top    - ciFittingThreshold <= rectTgt.Bottom))then begin
      if (Abs(rectForm.Left - rectTgt.Left) <= ciFittingThreshold) then begin
        Inc(rectForm.Left, rectTgt.Left - rectForm.Left);
      end else if (Abs(rectForm.Left  - rectTgt.Right) 
                   <= ciFittingThreshold) then begin
        Inc(rectForm.Left, rectTgt.Right - rectForm.Left);
      end;

      if (Abs(rectForm.Right - rectTgt.Right) <= ciFittingThreshold) then begin
        Inc(rectForm.Right, rectTgt.Right - rectForm.Right);
      end else if (Abs(rectForm.Right - rectTgt.Left ) 
                   <= ciFittingThreshold) then begin
        Inc(rectForm.Right, rectTgt.Left- rectForm.Right);
      end;
    end;

    if ((rectForm.Right + ciFittingThreshold >= rectTgt.Left ) and
        (rectForm.Left  - ciFittingThreshold <= rectTgt.Right))then begin
      if (Abs(rectForm.Top - rectTgt.Top) <= ciFittingThreshold) then begin
        Inc(rectForm.Top, rectTgt.Top - rectForm.Top);
      end else if (Abs(rectForm.Top  - rectTgt.Bottom) 
                   <= ciFittingThreshold) then begin
        Inc(rectForm.Top, rectTgt.Bottom - rectForm.Top);
      end;
      if (Abs(rectForm.Bottom - rectTgt.Bottom) 
          <= ciFittingThreshold) then begin
        Inc(rectForm.Bottom, rectTgt.Bottom - rectForm.Bottom);
      end else if (Abs(rectForm.Bottom - rectTgt.Top ) 
                   <= ciFittingThreshold) then begin
        Inc(rectForm.Bottom, rectTgt.Top - rectForm.Bottom);
      end;
    end;
  end;
{}
var
  iCntr   : integer;
  frmTmp  : TForm;
  rectScreen,
  rectTmp,
  rectBuf : TRect;
begin
  rectBuf := rectNew;

  if (SystemParametersInfo(SPI_GETWORKAREA, 0, @rectScreen, 0) 
                                                      = TRUE) then begin
    Sub(rectScreen, rectBuf);
  end;

  for iCntr := 0 to Screen.FormCount - 1 do begin
    frmTmp  := Screen.Forms[iCntr];
    if (frmTmp <> frmTgt) and (frmTmp.Visible) then begin
      GetWindowRect(frmTmp.Handle, rectTmp);
      Sub(rectTmp, rectBuf)
    end;
  end;

  case (iSide) of
    WMSZ_LEFT,
    WMSZ_TOPLEFT,
    WMSZ_BOTTOMLEFT  : rectNew.Left  := rectBuf.Left;
    WMSZ_RIGHT,
    WMSZ_TOPRIGHT,
    WMSZ_BOTTOMRIGHT : rectNew.Right := rectBuf.Right;
  end;

  case (iSide) of
    WMSZ_TOP,
    WMSZ_TOPLEFT,
    WMSZ_TOPRIGHT    : rectNew.Top    := rectBuf.Top;

    WMSZ_BOTTOM,
    WMSZ_BOTTOMLEFT,
    WMSZ_BOTTOMRIGHT : rectNew.Bottom := rectBuf.Bottom;
  end;
end;


procedure FormFitMoveToForms(frmTgt: TForm; var rectForm: TRect);
{}
  function SubH(const rectTgt: TRect): boolean;
  begin
    Result := FALSE;
    if ((rectForm.Bottom + ciFittingThreshold >= rectTgt.Top   ) and
        (rectForm.Top    - ciFittingThreshold <= rectTgt.Bottom))then begin
      if (Abs(rectForm.Left - rectTgt.Left) <= ciFittingThreshold) then begin
        OffsetRect(rectForm, rectTgt.Left - rectForm.Left, 0);
        Result := TRUE;
      end else if (Abs(rectForm.Right - rectTgt.Right) 
                   <= ciFittingThreshold) then begin
        OffsetRect(rectForm, rectTgt.Right - rectForm.Right, 0);
        Result := TRUE;
      end else if (Abs(rectForm.Left  - rectTgt.Right)
                   <= ciFittingThreshold) then begin
        OffsetRect(rectForm, rectTgt.Right - rectForm.Left, 0);
        Result := TRUE;
      end else if (Abs(rectForm.Right - rectTgt.Left ) 
                   <= ciFittingThreshold) then begin
        OffsetRect(rectForm, rectTgt.Left- rectForm.Right, 0);
        Result := TRUE;
      end;
    end;
  end;

  function SubV(const rectTgt: TRect): boolean;
  begin
    Result := FALSE;
    if ((rectForm.Right + ciFittingThreshold >= rectTgt.Left ) and
        (rectForm.Left  - ciFittingThreshold <= rectTgt.Right))then begin
      if (Abs(rectForm.Top - rectTgt.Top) <= ciFittingThreshold) then begin
        OffsetRect(rectForm, 0, rectTgt.Top - rectForm.Top);
        Result := TRUE;
      end else if (Abs(rectForm.Bottom - rectTgt.Bottom) 
                   <= ciFittingThreshold) then begin
        OffsetRect(rectForm, 0, rectTgt.Bottom - rectForm.Bottom);
        Result := TRUE;
      end else if (Abs(rectForm.Top  - rectTgt.Bottom) 
                   <= ciFittingThreshold) then begin
        OffsetRect(rectForm, 0, rectTgt.Bottom - rectForm.Top);
        Result := TRUE;
      end else if (Abs(rectForm.Bottom - rectTgt.Top ) 
                   <= ciFittingThreshold) then begin
        OffsetRect(rectForm, 0, rectTgt.Top - rectForm.Bottom);
        Result := TRUE;
      end;
    end;
  end;
{}
var
  iCntr       : integer;
  frmTmp      : TForm;
  rectTmp     : TRect;
  rectScreen  : TRect;
  boolScreen  : boolean;
begin
  boolScreen := SystemParametersInfo(SPI_GETWORKAREA, 0, @rectScreen, 0);

  if (boolScreen = FALSE) or (SubH(rectScreen) = FALSE) then begin
    for iCntr := 0 to Screen.FormCount - 1 do begin
      frmTmp  := Screen.Forms[iCntr];
      GetWindowRect(frmTmp.Handle, rectTmp);

      if (frmTmp <> frmTgt) and (frmTmp.Visible) then begin
        if (SubH(rectTmp)) then
          break;
      end;
    end;
  end;

  // 上下辺を上下辺に隣接させる
  if (boolScreen = FALSE) or (SubV(rectScreen) = FALSE) then begin
    for iCntr := 0 to Screen.FormCount - 1 do begin
      frmTmp  := Screen.Forms[iCntr];
      GetWindowRect(frmTmp.Handle, rectTmp);

      if (frmTmp <> frmTgt) and (frmTmp.Visible) then begin
        if (SubV(rectTmp)) then
          break;
      end;
    end;
  end;
end;

procedure TForm1.WMSizing(var MSG: Tmessage);
begin
  inherited;

  FormFitSizeToForms(Self, PRect(Msg.LParam)^, Msg.WParam);
  Msg.Result := -1;
end;

procedure TForm1.WMEnterSizeMove(var MSG: Tmessage);
begin
  inherited;

  FpntMoveOrg.X := Self.Left;
  FpntMoveOrg.Y := Self.Top;
  FpntMoveFit   := FpntMoveOrg;
end;

procedure TForm1.WMMoving(var MSG: Tmessage);
var
  rectNew : TRect;
  iWidth,
  iHeight : integer;
begin
  inherited;

  rectNew := PRect(Msg.LParam)^;

  FpntMoveOrg.X := FpntMoveOrg.X + rectNew.Left - FpntMoveFit.X;
  FpntMoveOrg.Y := FpntMoveOrg.Y + rectNew.Top  - FpntMoveFit.Y;

  iWidth  := rectNew.Right  - rectNew.Left;
  iHeight := rectNew.Bottom - rectNew.Top;

  rectNew.TopLeft := FpntMoveOrg;
  rectNew.Right   := FpntMoveOrg.X + iWidth;
  rectNew.Bottom  := FpntMoveOrg.Y + iHeight;

  FormFitMoveToForms(Self, rectNew);

  FpntMoveFit := rectNew.TopLeft;

  PRect(Msg.LParam)^ := rectNew;

  Msg.Result := -1;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  Form2.Show;
end;

                                  小塚  明義 (GGB02175)
                                  http://www.na.rim.or.jp/~akozuka/

Original document by 小塚　明義　　　氏 ID:(GGB02175)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。