Delphi - 一个FMX无边框窗口实现大小调整的代码(特此记录)

摘要： 效果图:无边框窗口的拖拽不多说了，直接StartWindowDrag就可以了。    无边框窗口的大小调整，在VCL下也有国外同行分享的一个很好的方案，...

效果图:

无边框窗口的拖拽不多说了，直接StartWindowDrag就可以了。    

无边框窗口的大小调整，在VCL下也有国外同行分享的一个很好的方案，但是FMX却没有人实现，VCL的代码拿过来没法直接用。

终于实现了，效果也还不错，当然希望有其他圈友有更好的方案，我这个就当抛砖引玉了。

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, FMX.Platform.Win,
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, SizeGripLayout,
  FMX.Controls.Presentation, FMX.StdCtrls, FMX.Objects, FMX.Layouts;

type
  TForm1 = class(TForm)
    Rectangle1: TRectangle;
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Rectangle1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Single);
  private
    FOldWndPrc : TFNWndProc;
    FFormStub : Pointer;
    procedure CreateHandle; override;
    procedure DestroyHandle; override;
    procedure CustomWndProc(var aMessage: TMessage);
  protected
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.fmx}
{$R *.Windows.fmx MSWINDOWS}

procedure TForm1.Button1Click(Sender: TObject);
begin
  Close;
end;

procedure TForm1.CreateHandle;
begin
  inherited CreateHandle;

  var eStyle := GetWindowLong(FmxHandleToHWND(Handle), GWL_STYLE);
  SetWindowLong(FmxHandleToHWND(Handle), GWL_STYLE, eStyle or WS_THICKFRAME);

  FFormStub  := MakeObjectInstance(CustomWndProc);
  FOldWndPrc := TFNWndProc(SetWindowLongPtr(FmxHandleToHWND(Handle), GWLP_WNDPROC, NativeInt(FFormStub)));
end;

procedure TForm1.CustomWndProc(var aMessage: TMessage);
const
  RESIZE_BORDER = 8;
var
  P: TPointF;
  Hit: Integer;
begin
  if aMessage.Msg = WM_NCHITTEST then
  begin
    P.X := SmallInt(LoWord(aMessage.LParam));
    P.Y := SmallInt(HiWord(aMessage.LParam));
    P := ScreenToClient(P);

    Hit := 0;
    if (P.X >= 0) and (P.X < RESIZE_BORDER) and (P.Y >= 0) and (P.Y < RESIZE_BORDER) then
      Hit := HTTOPLEFT
    else if (P.X >= ClientWidth - RESIZE_BORDER) and (P.X < ClientWidth) and (P.Y >= 0) and (P.Y < RESIZE_BORDER) then
      Hit := HTTOPRIGHT
    else if (P.X >= 0) and (P.X < RESIZE_BORDER) and (P.Y >= ClientHeight - RESIZE_BORDER) and (P.Y < ClientHeight) then
      Hit := HTBOTTOMLEFT
    else if (P.X >= ClientWidth - RESIZE_BORDER) and (P.X < ClientWidth) and (P.Y >= ClientHeight - RESIZE_BORDER) and (P.Y < ClientHeight) then
      Hit := HTBOTTOMRIGHT
    else if (P.Y >= 0) and (P.Y < RESIZE_BORDER) then
      Hit := HTTOP
    else if (P.Y >= ClientHeight - RESIZE_BORDER) and (P.Y < ClientHeight) then
      Hit := HTBOTTOM
    else if (P.X >= 0) and (P.X < RESIZE_BORDER) then
      Hit := HTLEFT
    else if (P.X >= ClientWidth - RESIZE_BORDER) and (P.X < ClientWidth) then
      Hit := HTRIGHT;

    if Hit <> 0 then
    begin
      aMessage.Result := Hit;
      Exit;
    end;
  end;

  aMessage.Result := CallWindowProc(FOldWndPrc, FmxHandleToHWND(Handle), aMessage.Msg, aMessage.wParam, aMessage.lParam);
end;

procedure TForm1.DestroyHandle;
begin
  SetWindowLongPtr(FmxHandleToHWND(Handle), GWLP_WNDPROC, NativeInt(FOldWndPrc));
  FreeObjectInstance(FFormStub);
  inherited DestroyHandle;
end;

procedure TForm1.Rectangle1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Single);
begin
  Self.StartWindowDrag;
end;

end.

  升级单元如下： 

unit Winapi.FormResizeHelper;

interface

uses
  System.Types,
  System.SysUtils,
  System.Classes,
  System.UITypes,
  FMX.Forms,
  FMX.Platform.Win,
  Winapi.Windows,
  Winapi.Messages;

type
  TFormResizeHelper = class( TObject )
  private
    FHandle     : HWND;
    FForm       : TForm;
    FResizeWidth: Integer;
    FOldWndProc : TFNWndProc;
    FFormStub   : Pointer;
    procedure CustomWndProc( var aMessage: TMessage );
  public
    constructor Create( AForm: TForm; const AResizeWidth: Integer = 8 );
    destructor Destroy; override;
  end;

implementation


{ TFormResizeHelper }

constructor TFormResizeHelper.Create( AForm: TForm; const AResizeWidth: Integer );
var
  LStyle: LongInt;
begin
  inherited Create;
  FForm        := AForm;
  FResizeWidth := AResizeWidth;

  if not Assigned( FForm ) then
    Exit;

  // Usa a função segura para obter o HWND
  FHandle := FormToHWND( FForm );

  if FHandle = 0 then
    Exit;

  // Adiciona o estilo que permite redimensionamento
  LStyle := GetWindowLong( FHandle, GWL_STYLE );
  SetWindowLong( FHandle, GWL_STYLE, LStyle or WS_THICKFRAME );

  // Subclassing: Substitui o WndProc para interceptar as mensagens
  FFormStub   := MakeObjectInstance( CustomWndProc );
  FOldWndProc := TFNWndProc( SetWindowLongPtr( FHandle, GWLP_WNDPROC, NativeInt( FFormStub ) ) );
end;

destructor TFormResizeHelper.Destroy;
begin
  if FHandle <> 0 then
  begin
    // Restaura o WndProc original
    SetWindowLongPtr( FHandle, GWLP_WNDPROC, NativeInt( FOldWndProc ) );
    // Libera a instância do nosso WndProc
    FreeObjectInstance( FFormStub );
  end;
  inherited Destroy;
end;

procedure TFormResizeHelper.CustomWndProc( var aMessage: TMessage );
var
  P       : TPointF;
  LHitTest: Integer;
begin
  if aMessage.Msg = WM_NCHITTEST then
  begin
    P := FForm.ScreenToClient( TPointF.Create( SmallInt( LoWord( aMessage.LParam ) ), SmallInt( HiWord( aMessage.LParam ) ) ) );

    LHitTest := 0;

    // Lógica para detectar se o mouse está nas bordas ou no topo
    if ( P.X >= 0 ) and ( P.X < FResizeWidth ) then
      LHitTest := HTLEFT
    else if P.X >= FForm.ClientWidth - FResizeWidth then
      LHitTest := HTRIGHT;

    if ( P.Y >= 0 ) and ( P.Y < FResizeWidth ) then
    begin
      if LHitTest = HTLEFT then
        LHitTest := HTTOPLEFT
      else if LHitTest = HTRIGHT then
        LHitTest := HTTOPRIGHT
      else
        LHitTest := HTTOP;
    end
    else if P.Y >= FForm.ClientHeight - FResizeWidth then
    begin
      if LHitTest = HTLEFT then
        LHitTest := HTBOTTOMLEFT
      else if LHitTest = HTRIGHT then
        LHitTest := HTBOTTOMRIGHT
      else
        LHitTest := HTBOTTOM;
    end
    else if LHitTest = 0 then
      LHitTest := HTCLIENT; // Retorna para a area do cliente

    // Permite arrastar o formulário clicando em qualquer lugar da área do cliente
    if LHitTest = HTCLIENT then
      aMessage.Result := HTCAPTION
    else if LHitTest <> 0 then
    begin
      aMessage.Result := LHitTest;
      Exit;
    end;
  end;
  //
  aMessage.Result := CallWindowProc( FOldWndProc, FHandle, aMessage.Msg, aMessage.wParam, aMessage.LParam );
end;

end.

----------
uses
  Winapi.FormResizeHelper;
...

procedure TForm1.Button1Click( Sender: TObject );
begin
  BorderStyle := TFmxFormBorderStyle.None; // testing...
  //
  TFormResizeHelper.Create( Self ); // apply changes...
end;