盒子论坛 v2.1

FMX窗口在WINDOWS桌面边缘停靠

在VCL窗体做这个功能非常简单，只要设定下窗口的
ScreenSnap和SnapBuffer就可以了。

但FMX因为跨平台原因，并没有提供这样的功能，尝
试自己重写WMWindowPosChanging消息，但FMX并没有
提供这种消息循环处理，所以你不会收到任何消息，
为了避免大家和我一样走弯路，下面贴出代码，这种
方式可以处理任何WINDOWS消息，这里只是用窗口在桌
面边缘停靠来演示一下FMX如何处理WINDOWS消息循环。

  protected
    {$IFDEF MSWINDOWS}
    procedure CreateHandle; override;
    procedure DestroyHandle; override;
    procedure WMWindowPosChanging(var Message: TWMWindowPosChanging); message WM_WINDOWPOSCHANGING;
    {$ENDIF}

.........

implementation

{$R *.fmx}

{$IFDEF MSWINDOWS}
uses
  FMX.Platform.Win, Winapi.Windows, Winapi.Commctrl;

function SubclassProc(Wnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM;
  uIdSubclass: UINT_PTR; RefData: DWORD_PTR): LRESULT; stdcall;
var
  Self: TfrmMain;
  Message: TMessage;
begin
  Result := DefSubclassProc(Wnd, Msg, wParam, lParam);
  case Msg of //你可以在这里处理其它WINDOWS消息
    WM_WINDOWPOSCHANGING:
    begin
      Self := TfrmMain(RefData);
      Message.Msg := Msg;
      Message.WParam := wParam;
      Message.LParam := lParam;
      Message.Result := Result;
      Self.Dispatch(Message);
      Result := Message.Result;
    end;
  end;
end;

procedure TfrmMain.CreateHandle;
var
  Wnd: HWND;
begin
  inherited;
  Wnd := WindowHandleToPlatform(Self.Handle).Wnd;
  SetWindowSubclass(Wnd, SubclassProc, 1, DWORD_PTR(Self));
end;

procedure TfrmMain.DestroyHandle;
var
  Wnd: HWND;
begin
  Wnd := WindowHandleToPlatform(Self.Handle).Wnd;
  RemoveWindowSubclass(Wnd, SubclassProc, 1);
  inherited;
end;

procedure TfrmMain.WMWindowPosChanging(var Message: TWMWindowPosChanging);
  procedure HandleEdge(var Edge: Integer; SnapToEdge: Integer;
    SnapDistance: Integer = 0);
  begin
    if (Abs(Edge + SnapDistance - SnapToEdge) < 15) then
      Edge := SnapToEdge - SnapDistance;
  end;
begin
  inherited;

  var WindowPos : PWindowPos;
  var LRect: TRect;
  WindowPos := Message.WindowPos;
  if (not (csDesigning in ComponentState)) and
    ((WindowPos.X <> 0) or (WindowPos.Y <> 0)) and
    ((WindowPos.cx = Width) and (WindowPos.cy = Height)) then
  begin
    LRect := Screen.WorkareaRect;
    HandleEdge(WindowPos.x, LRect.Left, 0);
    HandleEdge(WindowPos.y, LRect.Top, 0);
    HandleEdge(WindowPos.x, LRect.Right, Width);
    HandleEdge(WindowPos.y, LRect.Bottom, Height);
    Message.WindowPos := WindowPos;
  end;

  if (Message.WindowPos.y + Message.WindowPos.cy  > Screen.WorkAreaHeight) then begin
    Message.WindowPos.Y := Screen.WorkAreaHeight - Height;
  end;
  if (Message.WindowPos.x + Message.WindowPos.cx > Screen.WorkAreaWidth) then begin
    Message.WindowPos.X := Screen.WorkAreaWidth - Width;
  end;

  if Message.WindowPos.x<0 then
    Message.WindowPos.x := 0;
  if Message.WindowPos.y<0 then
    Message.WindowPos.y := 0;
end;
{$ENDIF}

..........

{$IFDEF MSWINDOWS}
var
  ICC: TInitCommonControlsEx;

initialization
  ICC.dwSize := SizeOf(ICC);
  ICC.dwICC  := ICC_STANDARD_CLASSES;
  InitCommonControlsEx(ICC);
{$ENDIF}

end.
----------------------------------------------
简单做人，认真做事。

作者：

tuesdays (Tuesday)	▲▲▲▲△	-
	普通会员

2021/2/28 11:23:32

1楼：

vcl有代码吗?
----------------------------------------------
delphi界写python最强, python界写delphi最强. 写自己的代码, 让别人去运行.

作者：

jackalan (nVicen)	★☆☆☆☆	-
	盒子活跃会员

2021/2/28 16:32:53

2楼：

@tuesdays
vcl不需要代码
设置窗口ScreenSnap为true
设置多少像素自动吸附即可，SnapBuffer设定为10-20。
----------------------------------------------
简单做人，认真做事。

作者：

tuesdays (Tuesday)	▲▲▲▲△	-
	普通会员

2021/2/28 19:59:53

3楼：

没这么简单吧, 我看网上的代码都写得很长啊..
类似QQ的自动收缩.
----------------------------------------------
delphi界写python最强, python界写delphi最强. 写自己的代码, 让别人去运行.

作者：

nevergrief (孤独骑士)	★☆☆☆☆	-
	盒子活跃会员

2021/2/28 20:29:02

4楼：

收藏了，谢谢楼主。
----------------------------------------------
只有偏执狂才能生存！

作者：

xiaoxingliang1 (xiaoxingliang1)	★☆☆☆☆	-
	普通会员

2021/3/1 10:39:52

5楼：

设置了ScreenSnap为true后，往左边边缘有用，右边没有效果。无边框窗体好像都没效果
----------------------------------------------
-

作者：

wfymqj (wfymqj)	★☆☆☆☆	-
	盒子活跃会员

2021/3/1 10:45:51

5楼：

收藏了，谢谢!
----------------------------------------------
-

信息

登陆以后才能回复