delphi 下拉弹出式窗体

{
 下拉弹出式窗体
 2022-04-07 by tag 649998142@qq.com
 这里写的比较简单只支持一个方向。靠左下拉的弹出式窗体
 窗口设置BorderStyle := bsNone; 但是要给窗口一个 WS_BORDER 支持改变大小在 WMNCHIST 消息里处理
 思路：
 FormDeactivate 失去焦点事件 关闭自己 (本程序转移焦点时，比如点到其他控件时)
 WMACTIVATEAPP 本窗口失去焦点消息 关闭自己 （切换到其他程序时）
 计算popup 坐标： 参考dev 的popupcontrol控件
 popupcontrol 可以修改大小是自己再做的一个逻辑判断是MouseMove MouseDown MouseUp 处理的

}
unit UPopupWindow;

interface

uses
  Windows, Classes, SysUtils, Messages, Controls, Forms, MultiMon;

const
 WM_InternelClose = WM_USER + 1;

type
  //弹出控件的信息 close的时候要还原回去
  TPopupControlData = record
    Align: TAlign;
    Bounds: TRect;
    Parent: TWinControl;
    Visible: Boolean;
    BorderStyle: TFormBorderStyle;
    ActiveControl: TWinControl;
  end;

  TPopupWindow = class(TForm)
    procedure FormDeactivate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormShow(Sender:TObject);
    procedure FormCreate(Sender:TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  private
     { Private declarations }
    FPrevActiveWindow: HWND;
    FPopupPoint:TPoint;
    FPopupControlData:TPopupControlData;
    FOnInitPopup, FOnPopup, FOnCloseUp : TNotifyEvent;
    FOnCloseQuery:TCloseQueryEvent;
    FPopupControl: TControl;
    FPopupControlParent :TWinControl;
    procedure WMNCHIST(var Msg: TMessage);message WM_NCHITTEST;
    procedure WMActivate(var Message: TWMActivate); message WM_ACTIVATE;
    procedure WMACTIVATEAPP(var Msg: TWMActivateApp);message WM_ACTIVATEAPP;
    procedure WMInternelClose(var Msg: TMessage);message WM_InternelClose;
    procedure CalculateSize(AFocusedControl: TWinControl);
    procedure Closeup;
    procedure SavePopupControlData;
    procedure RestorePopupControlData;
  public
     { Public declarations }
     constructor Create; reintroduce; overload;
     procedure CreateParams(var Params :TCreateParams);override;
     property OnInitPopup: TNotifyEvent read FOnInitPopup write FOnInitPopup;
     property OnPopup: TNotifyEvent read FOnPopup write FOnPopup;
     property CloseQuery: TCloseQueryEvent read FOnCloseQuery write FOnCloseQuery;
     property OnCloseUp: TNotifyEvent read FOnCloseUp write FOnCloseUp;
     property PopupControl: TControl read FPopupControl write FPopupControl;
     procedure InitPopup;
     procedure Popup(AFocusedControl: TWinControl); overload;
     procedure Popup(AFocusedControl: TWinControl; APopupControl:TControl); overload;
     procedure Popup(P:TPoint; APopupControl:TControl); overload;
  end;

implementation


{ TPopupWindow }
constructor TPopupWindow.Create;
begin
 CreateNew(nil);
 Visible := False;
 DefaultMonitor := dmDesktop;
 OnCreate := FormCreate;
 OnDeactivate := FormDeactivate;
 OnShow := FormShow;
 OnCloseQuery := FormCloseQuery;
 OnClose := FormClose;
 FPopupPoint := Point(0,0);
 DoubleBuffered := True;
end;

procedure TPopupWindow.CreateParams(var Params: TCreateParams);
begin
 //https://blog.csdn.net/suiyunonghen/article/details/2325416
  BorderStyle := bsNone;
  inherited;
//  Params.Style := WS_POPUP or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or WS_POPUPWINDOW;
  Params.Style := Params.Style or WS_BORDER;  //有个边框这样鼠标移动到边框就不会被控件给遮住了，不然放的控件如果是aclient 消息会穿透不了
 //下面这些虽然也可以，但是标题栏还是会有点空隙
// Params.Style := Params.Style or WS_THICKFRAME;
// Params.Style := Params.Style or WS_SIZEBOX;
end;

//弹出前先保存控件信息
procedure TPopupWindow.SavePopupControlData;
var
  APopupControl: TControl;
begin
  if FPopupControl <>  nil then
  with FPopupControl do
  begin
    FPopupControlData.Align := Align;
    if FPopupControl is TCustomForm then
    begin
      FPopupControlData.BorderStyle := TCustomForm(FPopupControl).BorderStyle;
      TCustomForm(FPopupControl).BorderStyle := bsNone;
    end;
    FPopupControlData.Bounds := BoundsRect;
    FPopupControlData.Parent := Parent;
    FPopupControlData.Visible := Visible;
    FPopupControlData.ActiveControl := nil;
    FPopupControl.Visible := True;
  end;
end;

//关闭时还原回去
procedure TPopupWindow.RestorePopupControlData;
begin
 if FPopupControl <> nil then
   with FPopupControl do
   begin
     while (FPopupControlData.ActiveControl <> nil) and (FPopupControlData.ActiveControl <> Self) do
     begin
       FPopupControlData.ActiveControl.Perform(CM_EXIT, 0, 0);
       FPopupControlData.ActiveControl := FPopupControlData.ActiveControl.Parent;
     end;
     Visible := False;
     Parent := FPopupControlData.Parent;
     Align := FPopupControlData.Align;
     //这里暂时不恢复， 下拉有可能改变了大小。下次下拉就还是一样就好了
//     BoundsRect := FPopupControlData.Bounds;
     Visible := FPopupControlData.Visible;
   end;
end;

//支持改变窗口大小
procedure TPopupWindow.WMNCHIST(var Msg: TMessage);
var
 MouseX,MouseY: integer;
begin
 MouseX := LOWORD(Msg.LParam);
 MouseY := HIWORD(Msg.LParam);
 if(MouseX >= Left + Width - 2) and (MouseY >= Top + Height - 2) then
   Msg.Result := HTBOTTOMRIGHT
 else if (MouseX <= Left + 2) and (MouseY <= Top + 3) then
  Msg.Result := HTTOPLEFT
 else if (MouseX <= Left + 2) and (MouseY<= Top + Height - 2) then
  Msg.Result := HTBOTTOMLEFT
 else if MouseX >= Left + Width -2 then
  Msg.Result := HTRIGHT
 else if MouseY >= Top + Height - 2 then
  Msg.Result := HTBOTTOM
 else if Mousex <= Left + 2 then
  Msg.Result := HTLEFT
 else if MouseY <= Top + 2 then
  Msg.Result := HTTOP
 else
 Inherited;
end;

procedure TPopupWindow.FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
// ShowWindow(Handle, SW_HIDE);
 if Assigned(OnCloseUp) then
  OnCloseUp(Self);
 RestorePopupControlData;
// Action := caFree;
end;

procedure TPopupWindow.FormDeactivate(Sender: TObject);
begin
 Closeup;
end;

procedure TPopupWindow.FormShow(Sender: TObject);
begin
 if Assigned(OnPopup) then
  OnPopup(Self);
end;

procedure TPopupWindow.FormCreate(Sender: TObject);
begin
 FOnInitPopup :=nil;
 FOnPopup := nil;
 FOnCloseUp := nil;
 FOnCloseQuery := nil;
 FPopupControl := nil;
end;

procedure TPopupWindow.FormCloseQuery(Sender: TObject;
  var CanClose: Boolean);
begin
 if Assigned(CloseQuery) then
  CloseQuery(Sender,CanClose);
end;

procedure TPopupWindow.InitPopup;
begin
 if Assigned(OnInitPopup) then
  OnInitPopup(Self);
end;

//计算窗口大小位置坐标
procedure TPopupWindow.CalculateSize(AFocusedControl: TWinControl);
 function GetMonitorWorkArea(const AMonitor: Integer): TRect;
 var
   Info: TMonitorInfo;
 begin
   if AMonitor = 0 then
     Result := Screen.WorkAreaRect
   else
   begin
     Info.cbSize := SizeOf(Info);
     GetMonitorInfo(AMonitor, @Info);
     Result := Info.rcWork;
   end;
 end;

 //获取桌面区域
 function GetDesktopWorkArea(const P: TPoint): TRect;
 begin
  //返回离该点最近的显示监视器的句柄。
   Result := GetMonitorWorkArea(MonitorFromPoint(P, MONITOR_DEFAULTTONEAREST));
 end;

 //获取要弹出的坐标
 function GetPopupPoint:TPoint;
 var
  OwnerBounds, AOwnerScreenBounds, ADesktopWorkArea:TRect;
  AParent: TWinControl;
  function MoreSpaceOnTop: Boolean;
  begin
   Result := AOwnerScreenBounds.Top - ADesktopWorkArea.Top > ADesktopWorkArea.Bottom - AOwnerScreenBounds.Bottom;
  end;
 begin
   //直接给出坐标
   if AFocusedControl = nil then
   begin
    Result := FPopupPoint;
    OwnerBounds := Rect(0,0,PopupControl.Width,2);
    OffsetRect(OwnerBounds, FPopupPoint.X, FPopupPoint.Y);
   end
   else
   begin
    Result := AFocusedControl.ClientToScreen(Point(0,AFocusedControl.Height));
    OwnerBounds := AFocusedControl.ClientRect;
    OffsetRect(OwnerBounds, AFocusedControl.Left, AFocusedControl.Top);
   end;
   
   AOwnerScreenBounds := OwnerBounds;
   //获取相对于屏幕的坐标
   if Assigned(AFocusedControl) and Assigned(AFocusedControl.Parent) then
    AParent := AFocusedControl.Parent
   else
    AParent := Application.MainForm;

  //转换出相对于屏幕的坐标
  with AOwnerScreenBounds do
  begin
   TopLeft := AParent.ClientToScreen(TopLeft);
   BottomRight := AParent.ClientToScreen(BottomRight);
  end;
  Result.X := AOwnerScreenBounds.Left;
  Result.Y := AOwnerScreenBounds.Bottom;

  //判断是否超出屏幕的区域 这里弹出只支持垂直的方向。
  ADesktopWorkArea := GetDesktopWorkArea(Result);

  //Y坐标判断 
  if (Result.Y + PopupControl.Height > ADesktopWorkArea.Bottom) and MoreSpaceOnTop then
    Result.Y := AOwnerScreenBounds.Top - PopupControl.Height;

  //判断X坐标
  if Result.X + Width > ADesktopWorkArea.Right then
    Result.X := ADesktopWorkArea.Right - Width;
    
  if Result.X < ADesktopWorkArea.Left then
     Result.X := ADesktopWorkArea.Left;
 end;
var
 p:TPoint;
begin
 if FPopupControl = nil then
 begin
  self.Width := 100;
  self.Height := 150;
 end
 else
 begin
  FPopupControlParent := FPopupControl.Parent;
  FPopupControl.Parent := Self;
//  Width := FPopupControl.Width;
//  Height := FPopupControl.Height;
  FPopupControl.Align := alClient;
  P := GetPopupPoint;
//  Left := p.X;
//  Top  := p.Y;
  SetBounds(p.X,p.Y, FPopupControl.Width, FPopupControl.Height);
 end;
end;

procedure TPopupWindow.Popup(AFocusedControl: TWinControl);
// function IsMouseDownMessage(AMsg: WPARAM): Boolean;
// begin
//   case AMsg of
//     WM_NCLBUTTONDOWN, WM_NCLBUTTONDBLCLK, WM_LBUTTONDOWN, WM_LBUTTONDBLCLK,
//     WM_NCRBUTTONDOWN, WM_NCRBUTTONDBLCLK, WM_RBUTTONDOWN, WM_RBUTTONDBLCLK,
//     WM_NCMBUTTONDOWN, WM_NCMBUTTONDBLCLK, WM_MBUTTONDOWN, WM_MBUTTONDBLCLK:
//       Result := True
//   else
//     Result := False;
//   end;
// end;
var
 Msg: TMsg;
begin
 SavePopupControlData;
 InitPopup;
 CalculateSize(AFocusedControl);
 Show;
 SetWindowPos(Handle, 0, 0, 0, 0, 0,
        SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or SWP_SHOWWINDOW);
// repeat
//  case Integer(GetMessage(Msg, 0, 0, 0)) of
//    -1: Break;
//    0:begin
//        PostQuitMessage(Msg.wParam);
//        Break;
//      end;
//  end;
//  TranslateMessage(Msg);
//  DispatchMessage(Msg);
//  if IsMouseDownMessage(Msg.message) then
//  begin
//   ShowWindow(Handle, SW_HIDE);
//   Hide;
//  end;
// until not Visible;
end;

procedure TPopupWindow.Popup(AFocusedControl: TWinControl;
  APopupControl: TControl);
begin
 PopupControl := APopupControl;
 FPopupPoint := Point(0,0);
 Popup(AFocusedControl);
end;

procedure TPopupWindow.Popup(P:TPoint; APopupControl:TControl);
begin
 PopupControl := APopupControl;
 FPopupPoint := P;
 Popup(nil);
end;

procedure TPopupWindow.Closeup;
begin
 Close;
end;

procedure TPopupWindow.WMActivate(var Message: TWMActivate); 
begin
 inherited;
 //失去激活
 if Message.Active <> WA_INACTIVE then
 begin
  //activeform 保持得到焦点 标题栏不会变成失去焦点的状态    向一个窗体发送 WM_NCACTIVATE 消息,可以是标题栏显示为激活或者非激活状态.
  FPrevActiveWindow := Message.ActiveWindow;
  SendMessage(FPrevActiveWindow, WM_NCACTIVATE, WPARAM(True), 0);
 end;
end;


procedure TPopupWindow.WMACTIVATEAPP(var Msg: TWMActivateApp);
begin
  inherited;
  //失去焦点
 if not Msg.Active then
 begin
  SendMessage(FPrevActiveWindow, WM_NCACTIVATE, WPARAM(False), 0);
  Closeup;
 end;
end;

procedure TPopupWindow.WMInternelClose(var Msg: TMessage);
begin
 Close;
end;

end.

 调用：

//弹出下拉form基于按钮

with TPopupWindow.Create do
  Popup(btn2, mmo1);

 //坐标是相对于form的
 with TPopupWindow.Create do
  Popup(Point(btn3.Left, btn3.Top+btn3.Height), mmo1);

这里创建后窗体是没有释放的。所以是要拿个全部变量存一下。最后释放掉
也可以修改源码，多一个参数出来，控制close 事件是否cafree

 另一个下拉窗口实现思路：

https://www.cnblogs.com/chilanger/p/14200347.html