如何在Delphi中模拟drop-down形式？
How to simulate drop-down form in Delphi?
如何使用Delphi创建"drop-down"window？
超出这一点的一切都是研究工作；并且与答案没有任何关系。
研究工作
制作一个合适的 drop-down 需要大量的零件一起仔细工作。我假设人们不喜欢这个困难的问题，而宁愿我问七个单独的问题；每一个都解决了一小部分问题。接下来的一切都是我 研究工作 解决看似简单的问题。
注意 drop-down window:
的定义特征
- 1. drop-down 延伸到 "owner" window[=236= 之外]
- 2. "owner" window保持焦点； drop-down 永远不会抢走焦点
- 3. drop-down window 有一个 drop-shadow
这是我在 WinForms 中问过的同一问题的 Delphi 变体：
- How to simulate a drop-down window in WinForms?
WinForms 中的答案是使用 ToolStripDropDown class。它是一个帮助器 class，可以将任何形式转换为 drop-down。
让我们在 Delphi
中完成
我将从创建一个华而不实的下拉表单开始，作为示例：
接下来我将放置一个按钮，这将是我单击以使 drop-down 出现的东西：
最后我会 wire-up 一些初始代码来显示需要在 OnClick:
中的表单
procedure TForm3.Button1MouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
frmPopup: TfrmPopup;
pt: TPoint;
begin
frmPopup := TfrmPopup.Create(Self);
//Show the form just under, and right aligned, to this button
pt := Self.ClientToScreen(Button1.BoundsRect.BottomRight);
Dec(pt.X, frmPopup.ClientWidth);
frmPopup.Show(Self, Self.Handle, pt);
end;
Edit：将其更改为 MouseDown 而不是 Click。单击不正确，因为 drop-down 无需单击即可显示。未解决的问题之一是如果用户再次 mouse-downs 按钮，如何 隐藏 一个 drop-down。但我们会把它留给回答问题的人来解决。这个问题中的所有内容都是研究工作 - 不是解决方案。
我们出发了：
现在如何正确操作？
我们注意到的第一件事是缺少 drop-shadow。那是因为我们需要应用 CS_DROPSHADOW window 样式：
procedure TfrmPopup.CreateParams(var Params: TCreateParams);
const
CS_DROPSHADOW = [=13=]020000;
begin
inherited CreateParams({var}Params);
Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW;
end;
解决了这个问题：
焦点窃取
下一个问题是在弹出窗口上调用 .Show 会导致它窃取焦点（应用程序的标题栏表明它已失去焦点）。 Sertac 提出了解决方案。
- 当弹出窗口收到
WM_Activate 消息，表明它正在接收焦点（即 Lo(wParam) <> WA_INACTIVE）：
- 发送 parent 表单
WM_NCActivate(True, -1) 以表明它应该像仍然有焦点一样绘制自己
我们处理 WM_Activate:
protected
procedure WMActivate(var Msg: TWMActivate); message WM_ACTIVATE;
和实施：
procedure TfrmPopup.WMActivate(var Msg: TWMActivate);
begin
//if we are being activated, then give pretend activation state back to our owner
if (Msg.Active <> WA_INACTIVE) then
SendMessage(Self.PopupParent.Handle, WM_NCACTIVATE, WPARAM(True), -1);
inherited;
end;
所以所有者 window 看起来它仍然有焦点（谁知道这是否是正确的方法 - 它只是 看起来 就像它仍然有焦点):
卷起来
幸运的是，Sertac 已经解决了如何在用户点击离开时关闭 window 的问题：
- 当弹出窗口收到
WM_Activate 消息，表明它正在失去焦点（即 Lo(wParam) = WA_INACTIVE）：
- 向所有者控件发送我们正在汇总的通知
- 释放弹出表单
我们将其添加到我们现有的 WM_Activate 处理程序中：
procedure TfrmPopup.WMActivate(var Msg: TWMActivate);
begin
//if we are being activated, then give pretend activation state back to our owner
if (Msg.Active <> WA_INACTIVE) then
SendMessage(Self.PopupParent.Handle, WM_NCACTIVATE, WPARAM(True), -1);
inherited;
//If we're being deactivated, then we need to rollup
if Msg.Active = WA_INACTIVE then
begin
//TODO: Tell our owner that we've rolled up
//Note: The parent should not be using rollup as the time to read the state of all controls in the popup.
// Every time something in the popup changes, the drop-down should give that inforamtion to the owner
Self.Release; //use Release to let WMActivate complete
end;
end;
滑动下拉菜单
下拉控件使用 AnimateWindow 将 drop-down 向下滑动。来自微软自己的 combo.c:
if (!(TEST_EffectPUSIF(PUSIF_COMBOBOXANIMATION))
|| (GetAppCompatFlags2(VER40) & GACF2_ANIMATIONOFF)) {
NtUserShowWindow(hwndList, SW_SHOWNA);
}
else
{
AnimateWindow(hwndList, CMS_QANIMATION, (fAnimPos ? AW_VER_POSITIVE :
AW_VER_NEGATIVE) | AW_SLIDE);
}
检查是否应该使用动画后，他们使用 AnimateWindow to show the window. We can use SystemParametersInfo 和 SPI_GetComboBoxAnimation:
Determines whether the slide-open effect for combo boxes is enabled. The pvParam parameter must point to a BOOL variable that receives TRUE for enabled, or FALSE for disabled.
在我们新奉献的 TfrmPopup.Show 方法中，我们可以检查 客户区动画 是否启用，然后调用 AnimateWindow 或 Show取决于用户的偏好：
procedure TfrmPopup.Show(Owner: TForm; NotificationParentWindow: HWND;
PopupPosition: TPoint);
var
pt: TPoint;
comboBoxAnimation: BOOL;
begin
FNotificationParentWnd := NotificationParentWindow;
//We want the dropdown form "owned" by (i.e. not "parented" to) the OwnerWindow
Self.Parent := nil; //the default anyway; but just to reinforce the idea
Self.PopupParent := Owner; //Owner means the Win32 concept of owner (i.e. always on top of, cf Parent, which means clipped child of)
Self.PopupMode := pmExplicit; //explicitely owned by the owner
//Show the form just under, and right aligned, to this button
Self.BorderStyle := bsNone;
Self.Position := poDesigned;
Self.Left := PopupPosition.X;
Self.Top := PopupPosition.Y;
if not Winapi.Windows.SystemParametersInfo(SPI_GETCOMBOBOXANIMATION, 0, @comboBoxAnimation, 0) then
comboBoxAnimation := False;
if comboBoxAnimation then
begin
//200ms is the shell animation duration
AnimateWindow(Self.Handle, 200, AW_VER_POSITIVE or AW_SLIDE or AW_ACTIVATE);
end
else
inherited Show;
end;
编辑：结果是 SPI_GETCOMBOBOXANIMATION 可能应该使用 SPI_GETCLIENTAREAANIMATION。点出了隐藏在微妙背后的深难"How to simulate a drop-down"。模拟一个 drop-down 需要很多东西。
问题是如果你试图在他们背后使用 ShowWindow 或 AnimateWindow，Delphi 表格几乎会摔死：
如何解决？
同样奇怪的是，Microsoft 本身也使用：
ShowWindow(..., SW_SHOWNOACTIVATE)，或AnimateWindow(...) *（没有 AW_ACTIVATE）
显示 drop-down 列表框 无需 激活。然而，在使用 Spy++ 监视 ComboBox 时，我可以看到 WM_NCACTIVATE 飞来飞去。
过去人们模拟幻灯片 window 使用重复调用从计时器更改 drop-down 表单的 Height。这不仅不好；但它也会改变表格的大小。形式不是向下滑动，而是向下生长；你可以看到所有的控件都改变了它们的布局drop-down 出现。不，让 drop-down 表格保持其实际大小，但向下滑动是这里需要的。
我知道 AnimateWindow 和 Delphi 从来没有相处过。在 Whosebug 出现很久之前，这个问题就已经被问了很多次了。我什至在 2005 年在新闻组上询问过它。但这不能阻止我再问。
我试图强制我的表单在动画后重绘：
AnimateWindow(Self.Handle, 200, AW_VER_POSITIVE or AW_SLIDE or AW_ACTIVATE);
Self.Repaint;
Self.Update;
Self.Invalidate;
但是不行；它只是坐在那里嘲笑我：
现在我想close-up
时再次显示
如果下拉组合框，并且用户尝试 MouseDown 按钮，真正的 Windows ComboBox 控件不会简单地再次显示该控件，而是而是隐藏它：
drop-down也知道它当前是"dropped-down"，这很有用，这样它就可以像在[=186中一样绘制自己=]"dropped down" 模式。我们需要的是一种知道 drop-down 被下拉的方法，以及一种知道 drop-down 不再被下拉的方法。某种布尔变量：
private
FDroppedDown: Boolean;
在我看来，我们需要告诉主机我们正在关闭（即失去激活）。 主持人需要负责销毁弹出窗口。 （主持人不能负责销毁弹出窗口；这会导致无法解决的竞争条件）.所以我创建了一条消息，用于通知所有者我们正在关闭：
const
WM_PopupFormCloseUp = WM_APP+89;
注意：我不知道人们如何避免消息常量冲突（特别是因为 CM_BASE 从 $B000 开始， CN_BASE 从 $BC00 开始).
基于 Sertac 的 activation/deactivation 例程：
procedure TfrmPopup.WMActivate(var Msg: TWMActivate);
begin
//if we are being activated, then give pretend activation state back to our owner
if (Msg.Active <> WA_INACTIVE) then
SendMessage(Self.PopupParent.Handle, WM_NCACTIVATE, WPARAM(True), -1);
inherited;
//If we're being deactivated, then we need to rollup
if Msg.Active = WA_INACTIVE then
begin
//DONE: Tell our owner that we've rolled up
//Note: We must post the message. If it is Sent, the owner
//will get the CloseUp notification before the MouseDown that
//started all this. When the MouseDown comes, they will think
//they were not dropped down, and drop down a new one.
PostMessage(FNotificationParentWnd, WM_PopupFormCloseUp, 0, 0);
Self.Release; //use release to give WM_Activate a chance to return
end;
end;
然后我们必须更改 MouseDown 代码以了解 drop-down 仍然存在：
procedure TForm3.Edit1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
frmPopup: TfrmPopup;
pt: TPoint;
begin
//If we (were) dropped down, then don't drop-down again.
//If they click us, pretend they are trying to close the drop-down rather than open a second copy
if FDroppedDown then
begin
//And since we're receiving mouse input, we by defintion must have focus.
//and since the drop-down self-destructs when it loses activation,
//it can no longer be dropped down (since it no longer exists)
Exit;
end;
frmPopup := TfrmPopup.Create(Self);
//Show the form just under, and right aligned, to this button
pt := Self.ClientToScreen(Edit1.BoundsRect.BottomRight);
Dec(pt.X, frmPopup.ClientWidth);
frmPopup.Show(Self, Self.Handle, pt);
FDroppedDown := True;
end;
我想就是这样
除了 AnimateWindow 难题之外，我可能已经能够利用我的研究成果来解决我能想到的所有问题，以便：
Simulate a drop-down form in Delphi
当然，这一切都可能是徒劳的。结果可能是有一个 VCL 函数：
TComboBoxHelper = class;
public
class procedure ShowDropDownForm(...);
end;
在这种情况下 将是正确答案。
在 procedure TForm3.Button1Click(Sender: TObject); 的底部你调用 frmPopup.Show; 将其更改为 ShowWindow(frmPopup.Handle, SW_SHOWNOACTIVATE); 然后你需要调用 frmPopup.Visible := True; 否则表单上的组件将不会显示
所以新程序看起来像这样：
uses
frmPopupU;
procedure TForm3.Button1Click(Sender: TObject);
var
frmPopup: TfrmPopup;
pt: TPoint;
begin
frmPopup := TfrmPopup.Create(Self);
frmPopup.BorderStyle := bsNone;
//We want the dropdown form "owned", but not "parented" to us
frmPopup.Parent := nil; //the default anyway; but just to reinforce the idea
frmPopup.PopupParent := Self;
//Show the form just under, and right aligned, to this button
frmPopup.Position := poDesigned;
pt := Self.ClientToScreen(Button1.BoundsRect.BottomRight);
Dec(pt.X, frmPopup.ClientWidth);
frmPopup.Left := pt.X;
frmPopup.Top := pt.Y;
// frmPopup.Show;
ShowWindow(frmPopup.Handle, SW_SHOWNOACTIVATE);
//Else the components on the form won't show
frmPopup.Visible := True;
end;
但这不会阻止您的弹出窗口窃取焦点。为了防止这种情况发生，您需要覆盖弹出表单中的 WM_MOUSEACTIVATE 事件
type
TfrmPopup = class(TForm)
...
procedure WMMouseActivate(var Message: TWMMouseActivate); message WM_MOUSEACTIVATE;
...
end;
以及实施
procedure TfrmPopup.WMMouseActivate(var Message: TWMMouseActivate);
begin
Message.Result := MA_NOACTIVATE;
end;
我决定尝试使用您的弹出窗口 window：我添加的第一件事是关闭按钮。只是一个简单的 TButton，它在其 onCLick 事件中调用 Close:
procedure TfrmPopup.Button1Click(Sender: TObject);
begin
Close;
end;
但这只会隐藏表单，为了释放它我添加了一个 OnFormClose 事件：
procedure TfrmPopup.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
end;
然后最后我觉得添加一个调整大小的功能会很有趣
我通过覆盖 WM_NCHITTEST 消息来做到这一点：
procedure TfrmPopup.WMNCHitTest(var Message: TWMNCHitTest);
const
EDGEDETECT = 7; //adjust to suit yourself
var
deltaRect: TRect; //not really used as a rect, just a convenient structure
begin
inherited;
with Message, deltaRect do
begin
Left := XPos - BoundsRect.Left;
Right := BoundsRect.Right - XPos;
Top := YPos - BoundsRect.Top;
Bottom := BoundsRect.Bottom - YPos;
if (Top < EDGEDETECT) and (Left < EDGEDETECT) then
Result := HTTOPLEFT
else if (Top < EDGEDETECT) and (Right < EDGEDETECT) then
Result := HTTOPRIGHT
else if (Bottom < EDGEDETECT) and (Left < EDGEDETECT) then
Result := HTBOTTOMLEFT
else if (Bottom < EDGEDETECT) and (Right < EDGEDETECT) then
Result := HTBOTTOMRIGHT
else if (Top < EDGEDETECT) then
Result := HTTOP
else if (Left < EDGEDETECT) then
Result := HTLEFT
else if (Bottom < EDGEDETECT) then
Result := HTBOTTOM
else if (Right < EDGEDETECT) then
Result := HTRIGHT;
end;
end;
所以最后我得到了这个：
unit frmPopupU;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TfrmPopup = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormCreate(Sender: TObject);
private
procedure WMMouseActivate(var Message: TWMMouseActivate); message WM_MOUSEACTIVATE;
procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
public
procedure CreateParams(var Params: TCreateParams); override;
end;
implementation
{$R *.dfm}
{ TfrmPopup }
procedure TfrmPopup.Button1Click(Sender: TObject);
begin
Close;
end;
procedure TfrmPopup.CreateParams(var Params: TCreateParams);
const
CS_DROPSHADOW = [=16=]020000;
begin
inherited CreateParams({var}Params);
Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW;
end;
procedure TfrmPopup.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
end;
procedure TfrmPopup.FormCreate(Sender: TObject);
begin
DoubleBuffered := true;
BorderStyle := bsNone;
end;
procedure TfrmPopup.WMMouseActivate(var Message: TWMMouseActivate);
begin
Message.Result := MA_NOACTIVATE;
end;
procedure TfrmPopup.WMNCHitTest(var Message: TWMNCHitTest);
const
EDGEDETECT = 7; //adjust to suit yourself
var
deltaRect: TRect; //not really used as a rect, just a convenient structure
begin
inherited;
with Message, deltaRect do
begin
Left := XPos - BoundsRect.Left;
Right := BoundsRect.Right - XPos;
Top := YPos - BoundsRect.Top;
Bottom := BoundsRect.Bottom - YPos;
if (Top < EDGEDETECT) and (Left < EDGEDETECT) then
Result := HTTOPLEFT
else if (Top < EDGEDETECT) and (Right < EDGEDETECT) then
Result := HTTOPRIGHT
else if (Bottom < EDGEDETECT) and (Left < EDGEDETECT) then
Result := HTBOTTOMLEFT
else if (Bottom < EDGEDETECT) and (Right < EDGEDETECT) then
Result := HTBOTTOMRIGHT
else if (Top < EDGEDETECT) then
Result := HTTOP
else if (Left < EDGEDETECT) then
Result := HTLEFT
else if (Bottom < EDGEDETECT) then
Result := HTBOTTOM
else if (Right < EDGEDETECT) then
Result := HTRIGHT;
end;
end;
end.
希望你能用得上。
完整的功能代码
以下单元仅在 Delphi 5（对 PopupParent 的模拟支持）中进行了测试。但除此之外，它还可以完成下拉菜单所需的一切。 Sertac 解决了 AnimateWindow 问题。
unit DropDownForm;
{
A drop-down style form.
Sample Usage
=================
procedure TForm1.SpeedButton1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
pt: TPoint;
begin
if FPopup = nil then
FPopup := TfrmOverdueReportsPopup.Create(Self);
if FPopup.DroppedDown then //don't drop-down again if we're already showing it
Exit;
pt := Self.ClientToScreen(SmartSpeedButton1.BoundsRect.BottomRight);
Dec(pt.X, FPopup.Width);
FPopup.ShowDropdown(Self, pt);
end;
Simply make a form descend from TDropDownForm.
Change:
type
TfrmOverdueReportsPopup = class(TForm)
to:
uses
DropDownForm;
type
TfrmOverdueReportsPopup = class(TDropDownForm)
}
interface
uses
Forms, Messages, Classes, Controls, Windows;
const
WM_PopupFormCloseUp = WM_USER+89;
type
TDropDownForm = class(TForm)
private
FOnCloseUp: TNotifyEvent;
FPopupParent: TCustomForm;
FResizable: Boolean;
function GetDroppedDown: Boolean;
{$IFNDEF SupportsPopupParent}
procedure SetPopupParent(const Value: TCustomForm);
{$ENDIF}
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure WMActivate(var Msg: TWMActivate); message WM_ACTIVATE;
procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
procedure DoCloseup; virtual;
procedure WMPopupFormCloseUp(var Msg: TMessage); message WM_PopupFormCloseUp;
{$IFNDEF SupportsPopupParent}
property PopupParent: TCustomForm read FPopupParent write SetPopupParent;
{$ENDIF}
public
constructor Create(AOwner: TComponent); override;
procedure ShowDropdown(OwnerForm: TCustomForm; PopupPosition: TPoint);
property DroppedDown: Boolean read GetDroppedDown;
property Resizable: Boolean read FResizable write FResizable;
property OnCloseUp: TNotifyEvent read FOnCloseUp write FOnCloseUp;
end;
implementation
uses
SysUtils;
{ TDropDownForm }
constructor TDropDownForm.Create(AOwner: TComponent);
begin
inherited;
Self.BorderStyle := bsNone; //get rid of our border right away, so the creator can measure us accurately
FResizable := True;
end;
procedure TDropDownForm.CreateParams(var Params: TCreateParams);
const
SPI_GETDROPSHADOW = 24;
CS_DROPSHADOW = [=17=]020000;
var
dropShadow: BOOL;
begin
inherited CreateParams({var}Params);
//It's no longer documented (because Windows 2000 is no longer supported)
//but use of CS_DROPSHADOW and SPI_GETDROPSHADOW are only supported on XP (5.1) or newer
if (Win32MajorVersion > 5) or ((Win32MajorVersion = 5) and (Win32MinorVersion >= 1)) then
begin
//Use of a drop-shadow is controlled by a system preference
if not Windows.SystemParametersInfo(SPI_GETDROPSHADOW, 0, @dropShadow, 0) then
dropShadow := False;
if dropShadow then
Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW;
end;
{$IFNDEF SupportsPopupParent} //Delphi 5 support for "PopupParent" style form ownership
if FPopupParent <> nil then
Params.WndParent := FPopupParent.Handle;
{$ENDIF}
end;
procedure TDropDownForm.DoCloseup;
begin
if Assigned(FOnCloseUp) then
FOnCloseUp(Self);
end;
function TDropDownForm.GetDroppedDown: Boolean;
begin
Result := (Self.Visible);
end;
{$IFNDEF SupportsPopupParent}
procedure TDropDownForm.SetPopupParent(const Value: TCustomForm);
begin
FPopupParent := Value;
end;
{$ENDIF}
procedure TDropDownForm.ShowDropdown(OwnerForm: TCustomForm; PopupPosition: TPoint);
var
comboBoxAnimation: BOOL;
i: Integer;
const
AnimationDuration = 200; //200 ms
begin
//We want the dropdown form "owned" by (i.e. not "parented" to) the OwnerForm
Self.Parent := nil; //the default anyway; but just to reinforce the idea
Self.PopupParent := OwnerForm; //Owner means the Win32 concept of owner (i.e. always on top of, cf Parent, which means clipped child of)
{$IFDEF SupportsPopupParent}
Self.PopupMode := pmExplicit; //explicitely owned by the owner
{$ENDIF}
//Show the form just under, and right aligned, to this button
// Self.BorderStyle := bsNone; moved to during FormCreate; so can creator can know our width for measurements
Self.Position := poDesigned;
Self.Left := PopupPosition.X;
Self.Top := PopupPosition.Y;
//Use of drop-down animation is controlled by preference
if not Windows.SystemParametersInfo(SPI_GETCOMBOBOXANIMATION, 0, @comboBoxAnimation, 0) then
comboBoxAnimation := False;
if comboBoxAnimation then
begin
//Delphi doesn't react well to having a form show behind its back (e.g. ShowWindow, AnimateWindow).
//Force Delphi to create all the WinControls so that they will exist when the form is shown.
for i := 0 to ControlCount - 1 do
begin
if Controls[i] is TWinControl and Controls[i].Visible and
not TWinControl(Controls[i]).HandleAllocated then
begin
TWinControl(Controls[i]).HandleNeeded;
SetWindowPos(TWinControl(Controls[i]).Handle, 0, 0, 0, 0, 0,
SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_SHOWWINDOW);
end;
end;
AnimateWindow(Self.Handle, AnimationDuration, AW_VER_POSITIVE or AW_SLIDE or AW_ACTIVATE);
Visible := True; // synch VCL
end
else
inherited Show;
end;
procedure TDropDownForm.WMActivate(var Msg: TWMActivate);
begin
//If we are being activated, then give pretend activation state back to our owner
if (Msg.Active <> WA_INACTIVE) then
SendMessage(Self.PopupParent.Handle, WM_NCACTIVATE, WPARAM(True), -1);
inherited;
//If we're being deactivated, then we need to rollup
if Msg.Active = WA_INACTIVE then
begin
{
Post a message (not Send a message) to oursleves that we're closing up.
This gives a chance for the mouse/keyboard event that triggered the closeup
to believe the drop-down is still dropped down.
This is intentional, so that the person dropping it down knows not to drop it down again.
They want clicking the button while is was dropped to hide it.
But in order to hide it, it must still be dropped down.
}
PostMessage(Self.Handle, WM_PopupFormCloseUp, WPARAM(Self), LPARAM(0));
end;
end;
procedure TDropDownForm.WMNCHitTest(var Message: TWMNCHitTest);
var
deltaRect: TRect; //not really used as a rect, just a convenient structure
cx, cy: Integer;
begin
inherited;
if not Self.Resizable then
Exit;
//The sizable border is a preference
cx := GetSystemMetrics(SM_CXSIZEFRAME);
cy := GetSystemMetrics(SM_CYSIZEFRAME);
with Message, deltaRect do
begin
Left := XPos - BoundsRect.Left;
Right := BoundsRect.Right - XPos;
Top := YPos - BoundsRect.Top;
Bottom := BoundsRect.Bottom - YPos;
if (Top < cy) and (Left < cx) then
Result := HTTOPLEFT
else if (Top < cy) and (Right < cx) then
Result := HTTOPRIGHT
else if (Bottom < cy) and (Left < cx) then
Result := HTBOTTOMLEFT
else if (Bottom < cy) and (Right < cx) then
Result := HTBOTTOMRIGHT
else if (Top < cy) then
Result := HTTOP
else if (Left < cx) then
Result := HTLEFT
else if (Bottom < cy) then
Result := HTBOTTOM
else if (Right < cx) then
Result := HTRIGHT;
end;
end;
procedure TDropDownForm.WMPopupFormCloseUp(var Msg: TMessage);
begin
//This message gets posted to us.
//Now it's time to actually closeup.
Self.Hide;
DoCloseup; //raise the OnCloseup event *after* we're actually hidden
end;
end.
How can i create a "drop-down" window using Delphi?
你把你总结的所有点点滴滴放在一起，没有一个 VCL class/function 会产生一个下拉表单。
虽然在您的研究中有几点需要提及。
首先，您将激活与焦点混淆了。当另一个 window 弹出在它前面时，焦点不会保留在调用表单中，激活是 - 或者看起来是这样。焦点是键盘输入的位置，它显然在 popped/dropped window 或其中的控件上。
AnimateWindow 不显示控件的问题是，VCL 不会创建 TWinControl 的基础原生（OS）控件，直到有必要（非 wincontrols 不是问题）。就 VCL 而言，通常不需要创建它们，直到它们可见为止，也就是当您将表单的 Visible 设置为 true（或调用 Show）时，从那时起您就不能这样做了将没有动画，当然除非你在动画之后设置 visible。
这也是您尝试刷新表单时缺少的要求：
AnimateWindow(Self.Handle, 200, AW_VER_POSITIVE or AW_SLIDE or AW_ACTIVATE);
Self.Repaint;
Self.Update;
Self.Invalidate;
请注意，在上面引用的问题中，none 次调用失败。但是没有什么可画的，形式还没有visible
任何强制创建控件并使它们可见的方法都会使您的动画栩栩如生。
...
if comboBoxAnimation then
begin
for i := 0 to ControlCount - 1 do
if Controls[i] is TWinControl and Controls[i].Visible and
not TWinControl(Controls[i]).HandleAllocated then begin
TWinControl(Controls[i]).HandleNeeded;
SetWindowPos(TWinControl(Controls[i]).Handle, 0, 0, 0, 0, 0,
SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or
SWP_SHOWWINDOW);
end;
AnimateWindow(Handle, 200, AW_VER_POSITIVE or AW_SLIDE or AW_ACTIVATE);
Visible := True; // synch VCL
end
else
...
这只是一个示例，在屏幕外显示表单或任何其他创意方法都同样有效。在这里，in this answer，我通过在将 visible 设置为 true 之前将动画表单的高度设置为“0”来实现相同的目的（不过我更喜欢这个答案中的方法..）。
关于在表单已经下拉时不再删除，您不必为此向调用表单post发送消息。实际上不要那样做，它需要调用表单的不必要的合作。永远只有一个实例被下拉，所以你可以使用一个全局的：
TfrmPopup = class(TForm)
...
procedure FormDestroy(Sender: TObject);
private
FNotificationParentWnd: HWND;
class var
FDroppedDown: Boolean;
protected
...
procedure TfrmPopup.Show(Owner: TForm; NotificationParentWindow: HWND;
...
if not FDroppedDown then begin
if comboBoxAnimation then begin
// animate as above
Visible := True; // synch with VCL
FDroppedDown := True;
end
else
inherited Show;
end;
end;
procedure TfrmPopup.FormDestroy(Sender: TObject);
begin
FDroppedDown := False;
end;
如何使用Delphi创建"drop-down"window？
超出这一点的一切都是研究工作；并且与答案没有任何关系。
研究工作
制作一个合适的 drop-down 需要大量的零件一起仔细工作。我假设人们不喜欢这个困难的问题，而宁愿我问七个单独的问题；每一个都解决了一小部分问题。接下来的一切都是我 研究工作 解决看似简单的问题。
注意 drop-down window:
的定义特征- 1. drop-down 延伸到 "owner" window[=236= 之外]
- 2. "owner" window保持焦点； drop-down 永远不会抢走焦点
- 3. drop-down window 有一个 drop-shadow
这是我在 WinForms 中问过的同一问题的 Delphi 变体：
- How to simulate a drop-down window in WinForms?
WinForms 中的答案是使用 ToolStripDropDown class。它是一个帮助器 class，可以将任何形式转换为 drop-down。
让我们在 Delphi
中完成我将从创建一个华而不实的下拉表单开始，作为示例：
接下来我将放置一个按钮，这将是我单击以使 drop-down 出现的东西：
最后我会 wire-up 一些初始代码来显示需要在 OnClick:
中的表单procedure TForm3.Button1MouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
frmPopup: TfrmPopup;
pt: TPoint;
begin
frmPopup := TfrmPopup.Create(Self);
//Show the form just under, and right aligned, to this button
pt := Self.ClientToScreen(Button1.BoundsRect.BottomRight);
Dec(pt.X, frmPopup.ClientWidth);
frmPopup.Show(Self, Self.Handle, pt);
end;
Edit：将其更改为 MouseDown 而不是 Click。单击不正确，因为 drop-down 无需单击即可显示。未解决的问题之一是如果用户再次 mouse-downs 按钮，如何 隐藏 一个 drop-down。但我们会把它留给回答问题的人来解决。这个问题中的所有内容都是研究工作 - 不是解决方案。
我们出发了：
现在如何正确操作？
我们注意到的第一件事是缺少 drop-shadow。那是因为我们需要应用 CS_DROPSHADOW window 样式：
procedure TfrmPopup.CreateParams(var Params: TCreateParams);
const
CS_DROPSHADOW = [=13=]020000;
begin
inherited CreateParams({var}Params);
Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW;
end;
解决了这个问题：
焦点窃取
下一个问题是在弹出窗口上调用 .Show 会导致它窃取焦点（应用程序的标题栏表明它已失去焦点）。 Sertac 提出了解决方案。
- 当弹出窗口收到
WM_Activate消息，表明它正在接收焦点（即Lo(wParam) <> WA_INACTIVE）： - 发送 parent 表单
WM_NCActivate(True, -1) 以表明它应该像仍然有焦点一样绘制自己
我们处理 WM_Activate:
protected
procedure WMActivate(var Msg: TWMActivate); message WM_ACTIVATE;
和实施：
procedure TfrmPopup.WMActivate(var Msg: TWMActivate);
begin
//if we are being activated, then give pretend activation state back to our owner
if (Msg.Active <> WA_INACTIVE) then
SendMessage(Self.PopupParent.Handle, WM_NCACTIVATE, WPARAM(True), -1);
inherited;
end;
所以所有者 window 看起来它仍然有焦点（谁知道这是否是正确的方法 - 它只是 看起来 就像它仍然有焦点):
卷起来
幸运的是，Sertac 已经解决了如何在用户点击离开时关闭 window 的问题：
- 当弹出窗口收到
WM_Activate消息，表明它正在失去焦点（即Lo(wParam) = WA_INACTIVE）： - 向所有者控件发送我们正在汇总的通知
- 释放弹出表单
我们将其添加到我们现有的 WM_Activate 处理程序中：
procedure TfrmPopup.WMActivate(var Msg: TWMActivate);
begin
//if we are being activated, then give pretend activation state back to our owner
if (Msg.Active <> WA_INACTIVE) then
SendMessage(Self.PopupParent.Handle, WM_NCACTIVATE, WPARAM(True), -1);
inherited;
//If we're being deactivated, then we need to rollup
if Msg.Active = WA_INACTIVE then
begin
//TODO: Tell our owner that we've rolled up
//Note: The parent should not be using rollup as the time to read the state of all controls in the popup.
// Every time something in the popup changes, the drop-down should give that inforamtion to the owner
Self.Release; //use Release to let WMActivate complete
end;
end;
滑动下拉菜单
下拉控件使用 AnimateWindow 将 drop-down 向下滑动。来自微软自己的 combo.c:
if (!(TEST_EffectPUSIF(PUSIF_COMBOBOXANIMATION))
|| (GetAppCompatFlags2(VER40) & GACF2_ANIMATIONOFF)) {
NtUserShowWindow(hwndList, SW_SHOWNA);
}
else
{
AnimateWindow(hwndList, CMS_QANIMATION, (fAnimPos ? AW_VER_POSITIVE :
AW_VER_NEGATIVE) | AW_SLIDE);
}
检查是否应该使用动画后，他们使用 AnimateWindow to show the window. We can use SystemParametersInfo 和 SPI_GetComboBoxAnimation:
Determines whether the slide-open effect for combo boxes is enabled. The pvParam parameter must point to a BOOL variable that receives TRUE for enabled, or FALSE for disabled.
在我们新奉献的 TfrmPopup.Show 方法中，我们可以检查 客户区动画 是否启用，然后调用 AnimateWindow 或 Show取决于用户的偏好：
procedure TfrmPopup.Show(Owner: TForm; NotificationParentWindow: HWND;
PopupPosition: TPoint);
var
pt: TPoint;
comboBoxAnimation: BOOL;
begin
FNotificationParentWnd := NotificationParentWindow;
//We want the dropdown form "owned" by (i.e. not "parented" to) the OwnerWindow
Self.Parent := nil; //the default anyway; but just to reinforce the idea
Self.PopupParent := Owner; //Owner means the Win32 concept of owner (i.e. always on top of, cf Parent, which means clipped child of)
Self.PopupMode := pmExplicit; //explicitely owned by the owner
//Show the form just under, and right aligned, to this button
Self.BorderStyle := bsNone;
Self.Position := poDesigned;
Self.Left := PopupPosition.X;
Self.Top := PopupPosition.Y;
if not Winapi.Windows.SystemParametersInfo(SPI_GETCOMBOBOXANIMATION, 0, @comboBoxAnimation, 0) then
comboBoxAnimation := False;
if comboBoxAnimation then
begin
//200ms is the shell animation duration
AnimateWindow(Self.Handle, 200, AW_VER_POSITIVE or AW_SLIDE or AW_ACTIVATE);
end
else
inherited Show;
end;
编辑：结果是 SPI_GETCOMBOBOXANIMATION 可能应该使用 SPI_GETCLIENTAREAANIMATION。点出了隐藏在微妙背后的深难"How to simulate a drop-down"。模拟一个 drop-down 需要很多东西。
问题是如果你试图在他们背后使用 ShowWindow 或 AnimateWindow，Delphi 表格几乎会摔死：
如何解决？
同样奇怪的是，Microsoft 本身也使用：
ShowWindow(..., SW_SHOWNOACTIVATE)，或AnimateWindow(...)*（没有AW_ACTIVATE）
显示 drop-down 列表框 无需 激活。然而，在使用 Spy++ 监视 ComboBox 时，我可以看到 WM_NCACTIVATE 飞来飞去。
过去人们模拟幻灯片 window 使用重复调用从计时器更改 drop-down 表单的 Height。这不仅不好；但它也会改变表格的大小。形式不是向下滑动，而是向下生长；你可以看到所有的控件都改变了它们的布局drop-down 出现。不，让 drop-down 表格保持其实际大小，但向下滑动是这里需要的。
我知道 AnimateWindow 和 Delphi 从来没有相处过。在 Whosebug 出现很久之前，这个问题就已经被问了很多次了。我什至在 2005 年在新闻组上询问过它。但这不能阻止我再问。
我试图强制我的表单在动画后重绘：
AnimateWindow(Self.Handle, 200, AW_VER_POSITIVE or AW_SLIDE or AW_ACTIVATE);
Self.Repaint;
Self.Update;
Self.Invalidate;
但是不行；它只是坐在那里嘲笑我：
现在我想close-up
时再次显示如果下拉组合框，并且用户尝试 MouseDown 按钮，真正的 Windows ComboBox 控件不会简单地再次显示该控件，而是而是隐藏它：
drop-down也知道它当前是"dropped-down"，这很有用，这样它就可以像在[=186中一样绘制自己=]"dropped down" 模式。我们需要的是一种知道 drop-down 被下拉的方法，以及一种知道 drop-down 不再被下拉的方法。某种布尔变量：
private
FDroppedDown: Boolean;
在我看来，我们需要告诉主机我们正在关闭（即失去激活）。 主持人需要负责销毁弹出窗口。 （主持人不能负责销毁弹出窗口；这会导致无法解决的竞争条件）.所以我创建了一条消息，用于通知所有者我们正在关闭：
const
WM_PopupFormCloseUp = WM_APP+89;
注意：我不知道人们如何避免消息常量冲突（特别是因为 CM_BASE 从 $B000 开始， CN_BASE 从 $BC00 开始).
基于 Sertac 的 activation/deactivation 例程：
procedure TfrmPopup.WMActivate(var Msg: TWMActivate);
begin
//if we are being activated, then give pretend activation state back to our owner
if (Msg.Active <> WA_INACTIVE) then
SendMessage(Self.PopupParent.Handle, WM_NCACTIVATE, WPARAM(True), -1);
inherited;
//If we're being deactivated, then we need to rollup
if Msg.Active = WA_INACTIVE then
begin
//DONE: Tell our owner that we've rolled up
//Note: We must post the message. If it is Sent, the owner
//will get the CloseUp notification before the MouseDown that
//started all this. When the MouseDown comes, they will think
//they were not dropped down, and drop down a new one.
PostMessage(FNotificationParentWnd, WM_PopupFormCloseUp, 0, 0);
Self.Release; //use release to give WM_Activate a chance to return
end;
end;
然后我们必须更改 MouseDown 代码以了解 drop-down 仍然存在：
procedure TForm3.Edit1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
frmPopup: TfrmPopup;
pt: TPoint;
begin
//If we (were) dropped down, then don't drop-down again.
//If they click us, pretend they are trying to close the drop-down rather than open a second copy
if FDroppedDown then
begin
//And since we're receiving mouse input, we by defintion must have focus.
//and since the drop-down self-destructs when it loses activation,
//it can no longer be dropped down (since it no longer exists)
Exit;
end;
frmPopup := TfrmPopup.Create(Self);
//Show the form just under, and right aligned, to this button
pt := Self.ClientToScreen(Edit1.BoundsRect.BottomRight);
Dec(pt.X, frmPopup.ClientWidth);
frmPopup.Show(Self, Self.Handle, pt);
FDroppedDown := True;
end;
我想就是这样
除了 AnimateWindow 难题之外，我可能已经能够利用我的研究成果来解决我能想到的所有问题，以便：
Simulate a drop-down form in Delphi
当然，这一切都可能是徒劳的。结果可能是有一个 VCL 函数：
TComboBoxHelper = class;
public
class procedure ShowDropDownForm(...);
end;
在这种情况下 将是正确答案。
在 procedure TForm3.Button1Click(Sender: TObject); 的底部你调用 frmPopup.Show; 将其更改为 ShowWindow(frmPopup.Handle, SW_SHOWNOACTIVATE); 然后你需要调用 frmPopup.Visible := True; 否则表单上的组件将不会显示
所以新程序看起来像这样：
uses
frmPopupU;
procedure TForm3.Button1Click(Sender: TObject);
var
frmPopup: TfrmPopup;
pt: TPoint;
begin
frmPopup := TfrmPopup.Create(Self);
frmPopup.BorderStyle := bsNone;
//We want the dropdown form "owned", but not "parented" to us
frmPopup.Parent := nil; //the default anyway; but just to reinforce the idea
frmPopup.PopupParent := Self;
//Show the form just under, and right aligned, to this button
frmPopup.Position := poDesigned;
pt := Self.ClientToScreen(Button1.BoundsRect.BottomRight);
Dec(pt.X, frmPopup.ClientWidth);
frmPopup.Left := pt.X;
frmPopup.Top := pt.Y;
// frmPopup.Show;
ShowWindow(frmPopup.Handle, SW_SHOWNOACTIVATE);
//Else the components on the form won't show
frmPopup.Visible := True;
end;
但这不会阻止您的弹出窗口窃取焦点。为了防止这种情况发生，您需要覆盖弹出表单中的 WM_MOUSEACTIVATE 事件
type
TfrmPopup = class(TForm)
...
procedure WMMouseActivate(var Message: TWMMouseActivate); message WM_MOUSEACTIVATE;
...
end;
以及实施
procedure TfrmPopup.WMMouseActivate(var Message: TWMMouseActivate);
begin
Message.Result := MA_NOACTIVATE;
end;
我决定尝试使用您的弹出窗口 window：我添加的第一件事是关闭按钮。只是一个简单的 TButton，它在其 onCLick 事件中调用 Close:
procedure TfrmPopup.Button1Click(Sender: TObject);
begin
Close;
end;
但这只会隐藏表单，为了释放它我添加了一个 OnFormClose 事件：
procedure TfrmPopup.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
end;
然后最后我觉得添加一个调整大小的功能会很有趣
我通过覆盖 WM_NCHITTEST 消息来做到这一点：
procedure TfrmPopup.WMNCHitTest(var Message: TWMNCHitTest);
const
EDGEDETECT = 7; //adjust to suit yourself
var
deltaRect: TRect; //not really used as a rect, just a convenient structure
begin
inherited;
with Message, deltaRect do
begin
Left := XPos - BoundsRect.Left;
Right := BoundsRect.Right - XPos;
Top := YPos - BoundsRect.Top;
Bottom := BoundsRect.Bottom - YPos;
if (Top < EDGEDETECT) and (Left < EDGEDETECT) then
Result := HTTOPLEFT
else if (Top < EDGEDETECT) and (Right < EDGEDETECT) then
Result := HTTOPRIGHT
else if (Bottom < EDGEDETECT) and (Left < EDGEDETECT) then
Result := HTBOTTOMLEFT
else if (Bottom < EDGEDETECT) and (Right < EDGEDETECT) then
Result := HTBOTTOMRIGHT
else if (Top < EDGEDETECT) then
Result := HTTOP
else if (Left < EDGEDETECT) then
Result := HTLEFT
else if (Bottom < EDGEDETECT) then
Result := HTBOTTOM
else if (Right < EDGEDETECT) then
Result := HTRIGHT;
end;
end;
所以最后我得到了这个：
unit frmPopupU;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TfrmPopup = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormCreate(Sender: TObject);
private
procedure WMMouseActivate(var Message: TWMMouseActivate); message WM_MOUSEACTIVATE;
procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
public
procedure CreateParams(var Params: TCreateParams); override;
end;
implementation
{$R *.dfm}
{ TfrmPopup }
procedure TfrmPopup.Button1Click(Sender: TObject);
begin
Close;
end;
procedure TfrmPopup.CreateParams(var Params: TCreateParams);
const
CS_DROPSHADOW = [=16=]020000;
begin
inherited CreateParams({var}Params);
Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW;
end;
procedure TfrmPopup.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
end;
procedure TfrmPopup.FormCreate(Sender: TObject);
begin
DoubleBuffered := true;
BorderStyle := bsNone;
end;
procedure TfrmPopup.WMMouseActivate(var Message: TWMMouseActivate);
begin
Message.Result := MA_NOACTIVATE;
end;
procedure TfrmPopup.WMNCHitTest(var Message: TWMNCHitTest);
const
EDGEDETECT = 7; //adjust to suit yourself
var
deltaRect: TRect; //not really used as a rect, just a convenient structure
begin
inherited;
with Message, deltaRect do
begin
Left := XPos - BoundsRect.Left;
Right := BoundsRect.Right - XPos;
Top := YPos - BoundsRect.Top;
Bottom := BoundsRect.Bottom - YPos;
if (Top < EDGEDETECT) and (Left < EDGEDETECT) then
Result := HTTOPLEFT
else if (Top < EDGEDETECT) and (Right < EDGEDETECT) then
Result := HTTOPRIGHT
else if (Bottom < EDGEDETECT) and (Left < EDGEDETECT) then
Result := HTBOTTOMLEFT
else if (Bottom < EDGEDETECT) and (Right < EDGEDETECT) then
Result := HTBOTTOMRIGHT
else if (Top < EDGEDETECT) then
Result := HTTOP
else if (Left < EDGEDETECT) then
Result := HTLEFT
else if (Bottom < EDGEDETECT) then
Result := HTBOTTOM
else if (Right < EDGEDETECT) then
Result := HTRIGHT;
end;
end;
end.
希望你能用得上。
完整的功能代码
以下单元仅在 Delphi 5（对 PopupParent 的模拟支持）中进行了测试。但除此之外，它还可以完成下拉菜单所需的一切。 Sertac 解决了 AnimateWindow 问题。
unit DropDownForm;
{
A drop-down style form.
Sample Usage
=================
procedure TForm1.SpeedButton1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
pt: TPoint;
begin
if FPopup = nil then
FPopup := TfrmOverdueReportsPopup.Create(Self);
if FPopup.DroppedDown then //don't drop-down again if we're already showing it
Exit;
pt := Self.ClientToScreen(SmartSpeedButton1.BoundsRect.BottomRight);
Dec(pt.X, FPopup.Width);
FPopup.ShowDropdown(Self, pt);
end;
Simply make a form descend from TDropDownForm.
Change:
type
TfrmOverdueReportsPopup = class(TForm)
to:
uses
DropDownForm;
type
TfrmOverdueReportsPopup = class(TDropDownForm)
}
interface
uses
Forms, Messages, Classes, Controls, Windows;
const
WM_PopupFormCloseUp = WM_USER+89;
type
TDropDownForm = class(TForm)
private
FOnCloseUp: TNotifyEvent;
FPopupParent: TCustomForm;
FResizable: Boolean;
function GetDroppedDown: Boolean;
{$IFNDEF SupportsPopupParent}
procedure SetPopupParent(const Value: TCustomForm);
{$ENDIF}
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure WMActivate(var Msg: TWMActivate); message WM_ACTIVATE;
procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
procedure DoCloseup; virtual;
procedure WMPopupFormCloseUp(var Msg: TMessage); message WM_PopupFormCloseUp;
{$IFNDEF SupportsPopupParent}
property PopupParent: TCustomForm read FPopupParent write SetPopupParent;
{$ENDIF}
public
constructor Create(AOwner: TComponent); override;
procedure ShowDropdown(OwnerForm: TCustomForm; PopupPosition: TPoint);
property DroppedDown: Boolean read GetDroppedDown;
property Resizable: Boolean read FResizable write FResizable;
property OnCloseUp: TNotifyEvent read FOnCloseUp write FOnCloseUp;
end;
implementation
uses
SysUtils;
{ TDropDownForm }
constructor TDropDownForm.Create(AOwner: TComponent);
begin
inherited;
Self.BorderStyle := bsNone; //get rid of our border right away, so the creator can measure us accurately
FResizable := True;
end;
procedure TDropDownForm.CreateParams(var Params: TCreateParams);
const
SPI_GETDROPSHADOW = 24;
CS_DROPSHADOW = [=17=]020000;
var
dropShadow: BOOL;
begin
inherited CreateParams({var}Params);
//It's no longer documented (because Windows 2000 is no longer supported)
//but use of CS_DROPSHADOW and SPI_GETDROPSHADOW are only supported on XP (5.1) or newer
if (Win32MajorVersion > 5) or ((Win32MajorVersion = 5) and (Win32MinorVersion >= 1)) then
begin
//Use of a drop-shadow is controlled by a system preference
if not Windows.SystemParametersInfo(SPI_GETDROPSHADOW, 0, @dropShadow, 0) then
dropShadow := False;
if dropShadow then
Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW;
end;
{$IFNDEF SupportsPopupParent} //Delphi 5 support for "PopupParent" style form ownership
if FPopupParent <> nil then
Params.WndParent := FPopupParent.Handle;
{$ENDIF}
end;
procedure TDropDownForm.DoCloseup;
begin
if Assigned(FOnCloseUp) then
FOnCloseUp(Self);
end;
function TDropDownForm.GetDroppedDown: Boolean;
begin
Result := (Self.Visible);
end;
{$IFNDEF SupportsPopupParent}
procedure TDropDownForm.SetPopupParent(const Value: TCustomForm);
begin
FPopupParent := Value;
end;
{$ENDIF}
procedure TDropDownForm.ShowDropdown(OwnerForm: TCustomForm; PopupPosition: TPoint);
var
comboBoxAnimation: BOOL;
i: Integer;
const
AnimationDuration = 200; //200 ms
begin
//We want the dropdown form "owned" by (i.e. not "parented" to) the OwnerForm
Self.Parent := nil; //the default anyway; but just to reinforce the idea
Self.PopupParent := OwnerForm; //Owner means the Win32 concept of owner (i.e. always on top of, cf Parent, which means clipped child of)
{$IFDEF SupportsPopupParent}
Self.PopupMode := pmExplicit; //explicitely owned by the owner
{$ENDIF}
//Show the form just under, and right aligned, to this button
// Self.BorderStyle := bsNone; moved to during FormCreate; so can creator can know our width for measurements
Self.Position := poDesigned;
Self.Left := PopupPosition.X;
Self.Top := PopupPosition.Y;
//Use of drop-down animation is controlled by preference
if not Windows.SystemParametersInfo(SPI_GETCOMBOBOXANIMATION, 0, @comboBoxAnimation, 0) then
comboBoxAnimation := False;
if comboBoxAnimation then
begin
//Delphi doesn't react well to having a form show behind its back (e.g. ShowWindow, AnimateWindow).
//Force Delphi to create all the WinControls so that they will exist when the form is shown.
for i := 0 to ControlCount - 1 do
begin
if Controls[i] is TWinControl and Controls[i].Visible and
not TWinControl(Controls[i]).HandleAllocated then
begin
TWinControl(Controls[i]).HandleNeeded;
SetWindowPos(TWinControl(Controls[i]).Handle, 0, 0, 0, 0, 0,
SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_SHOWWINDOW);
end;
end;
AnimateWindow(Self.Handle, AnimationDuration, AW_VER_POSITIVE or AW_SLIDE or AW_ACTIVATE);
Visible := True; // synch VCL
end
else
inherited Show;
end;
procedure TDropDownForm.WMActivate(var Msg: TWMActivate);
begin
//If we are being activated, then give pretend activation state back to our owner
if (Msg.Active <> WA_INACTIVE) then
SendMessage(Self.PopupParent.Handle, WM_NCACTIVATE, WPARAM(True), -1);
inherited;
//If we're being deactivated, then we need to rollup
if Msg.Active = WA_INACTIVE then
begin
{
Post a message (not Send a message) to oursleves that we're closing up.
This gives a chance for the mouse/keyboard event that triggered the closeup
to believe the drop-down is still dropped down.
This is intentional, so that the person dropping it down knows not to drop it down again.
They want clicking the button while is was dropped to hide it.
But in order to hide it, it must still be dropped down.
}
PostMessage(Self.Handle, WM_PopupFormCloseUp, WPARAM(Self), LPARAM(0));
end;
end;
procedure TDropDownForm.WMNCHitTest(var Message: TWMNCHitTest);
var
deltaRect: TRect; //not really used as a rect, just a convenient structure
cx, cy: Integer;
begin
inherited;
if not Self.Resizable then
Exit;
//The sizable border is a preference
cx := GetSystemMetrics(SM_CXSIZEFRAME);
cy := GetSystemMetrics(SM_CYSIZEFRAME);
with Message, deltaRect do
begin
Left := XPos - BoundsRect.Left;
Right := BoundsRect.Right - XPos;
Top := YPos - BoundsRect.Top;
Bottom := BoundsRect.Bottom - YPos;
if (Top < cy) and (Left < cx) then
Result := HTTOPLEFT
else if (Top < cy) and (Right < cx) then
Result := HTTOPRIGHT
else if (Bottom < cy) and (Left < cx) then
Result := HTBOTTOMLEFT
else if (Bottom < cy) and (Right < cx) then
Result := HTBOTTOMRIGHT
else if (Top < cy) then
Result := HTTOP
else if (Left < cx) then
Result := HTLEFT
else if (Bottom < cy) then
Result := HTBOTTOM
else if (Right < cx) then
Result := HTRIGHT;
end;
end;
procedure TDropDownForm.WMPopupFormCloseUp(var Msg: TMessage);
begin
//This message gets posted to us.
//Now it's time to actually closeup.
Self.Hide;
DoCloseup; //raise the OnCloseup event *after* we're actually hidden
end;
end.
How can i create a "drop-down" window using Delphi?
你把你总结的所有点点滴滴放在一起，没有一个 VCL class/function 会产生一个下拉表单。
虽然在您的研究中有几点需要提及。
首先，您将激活与焦点混淆了。当另一个 window 弹出在它前面时，焦点不会保留在调用表单中，激活是 - 或者看起来是这样。焦点是键盘输入的位置，它显然在 popped/dropped window 或其中的控件上。
AnimateWindow 不显示控件的问题是，VCL 不会创建 TWinControl 的基础原生（OS）控件，直到有必要（非 wincontrols 不是问题）。就 VCL 而言，通常不需要创建它们，直到它们可见为止，也就是当您将表单的 Visible 设置为 true（或调用 Show）时，从那时起您就不能这样做了将没有动画，当然除非你在动画之后设置 visible。
这也是您尝试刷新表单时缺少的要求：
AnimateWindow(Self.Handle, 200, AW_VER_POSITIVE or AW_SLIDE or AW_ACTIVATE);
Self.Repaint;
Self.Update;
Self.Invalidate;
请注意，在上面引用的问题中，none 次调用失败。但是没有什么可画的，形式还没有visible
任何强制创建控件并使它们可见的方法都会使您的动画栩栩如生。
...
if comboBoxAnimation then
begin
for i := 0 to ControlCount - 1 do
if Controls[i] is TWinControl and Controls[i].Visible and
not TWinControl(Controls[i]).HandleAllocated then begin
TWinControl(Controls[i]).HandleNeeded;
SetWindowPos(TWinControl(Controls[i]).Handle, 0, 0, 0, 0, 0,
SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or
SWP_SHOWWINDOW);
end;
AnimateWindow(Handle, 200, AW_VER_POSITIVE or AW_SLIDE or AW_ACTIVATE);
Visible := True; // synch VCL
end
else
...
这只是一个示例，在屏幕外显示表单或任何其他创意方法都同样有效。在这里，in this answer，我通过在将 visible 设置为 true 之前将动画表单的高度设置为“0”来实现相同的目的（不过我更喜欢这个答案中的方法..）。
关于在表单已经下拉时不再删除，您不必为此向调用表单post发送消息。实际上不要那样做，它需要调用表单的不必要的合作。永远只有一个实例被下拉，所以你可以使用一个全局的：
TfrmPopup = class(TForm)
...
procedure FormDestroy(Sender: TObject);
private
FNotificationParentWnd: HWND;
class var
FDroppedDown: Boolean;
protected
...
procedure TfrmPopup.Show(Owner: TForm; NotificationParentWindow: HWND;
...
if not FDroppedDown then begin
if comboBoxAnimation then begin
// animate as above
Visible := True; // synch with VCL
FDroppedDown := True;
end
else
inherited Show;
end;
end;
procedure TfrmPopup.FormDestroy(Sender: TObject);
begin
FDroppedDown := False;
end;