delphi 下拉彈出式窗體

阿新 • • 發佈：2022-04-07

{
 下拉彈出式窗體
 2022-04-07 by tag [email protected]
 這裡寫的比較簡單隻支援一個方向。靠左下拉的彈出式窗體
 視窗設定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