How to simulate drop-down form in Delphi? How to simulate drop-down form in Delphi? shell shell

How to simulate drop-down form in Delphi?


At the bottom of procedure TForm3.Button1Click(Sender: TObject); you call frmPopup.Show; change that to ShowWindow(frmPopup.Handle, SW_SHOWNOACTIVATE); and after that you need to call frmPopup.Visible := True; else the components on the form won't show

So the new procedure looks like this:

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;

But this won't prevent you popup from stealing focus. Inorder for preventing that, you need to override the WM_MOUSEACTIVATE event in your popup form

type  TfrmPopup = class(TForm)...    procedure WMMouseActivate(var Message: TWMMouseActivate); message WM_MOUSEACTIVATE;...  end;

And the implementation

procedure TfrmPopup.WMMouseActivate(var Message: TWMMouseActivate);begin  Message.Result := MA_NOACTIVATE;end;

I've decided to play arround with your popup window: The first thing I added was a close button. Just a simple TButton which in its onCLick Event calls Close:

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

But that would only hide the form, in order for freeing it I added a OnFormClose event:

procedure TfrmPopup.FormClose(Sender: TObject; var Action: TCloseAction);begin  Action := caFree;end;

Then finally I thought it would be funny to add a resize function

I did that by overriding the WM_NCHITTEST Message :

procedure TfrmPopup.WMNCHitTest(var Message: TWMNCHitTest);const  EDGEDETECT = 7; //adjust to suit yourselfvar  deltaRect: TRect; //not really used as a rect, just a convenient structurebegin  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;

So finally I've ended up with this :

unit frmPopupU;interfaceuses  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 = $00020000;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 yourselfvar  deltaRect: TRect; //not really used as a rect, just a convenient structurebegin  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.

Hope you can use it.

Full and functional code

The following unit was tested only in Delphi 5 (emulated support for PopupParent). But beyond that, it does everything a drop-down needs. Sertac solved the AnimateWindow problem.

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)}interfaceuses    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;implementationuses    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 = $1024;    CS_DROPSHADOW = $00020000;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 msbegin    //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 hiddenend;end.


How can i create a "drop-down" window using Delphi?

You put together all the bits and pieces you have summarized, there is no one VCL class/function that would produce a drop down form.

There are a few points to mention in your research though.


First, you're confusing activation with focus. Focus is not preserved in the calling form when another window pops in front of it, activation is - or it seems that way. Focus is where keyboard input goes, it is obviously on either the popped/dropped window or on a control in it.


Your problem with controls not showing with AnimateWindow is that, VCL does not create underlying native (OS) controls of TWinControls until it is necessary (non-wincontrols are not a problem). As far as VCL is concerned, creating them is not normally necessary until they will be visible, which is when you set Visible of your form to true (or call Show), which you cannot since then there will be no animation, unless of course you set visible after the animation.

This is also the missing requirement when you try to refresh your form:

AnimateWindow(Self.Handle, 200, AW_VER_POSITIVE or AW_SLIDE or AW_ACTIVATE);Self.Repaint;Self.Update;Self.Invalidate;

Notice that in the above quote from the question, none of the calls fail. But there's nothing to paint, the form is not even visible yet.

Any means of forcing the controls to be created and making them visible will make your animation come alive.

...if comboBoxAnimation thenbegin  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 VCLendelse  ...

This is just an example, showing the form off-screen or any other creative method could work equally well. Here, in this answer, I achieve the same by setting animated form's height to '0' before setting visible to true (I like the approach in this answer better though..).


Regarding not dropping again when the form is already dropped down, you don't have to post a message to the calling form for that. In fact don't do that, it requires unnecessary cooperation from the calling form. There will ever be only one instance to be dropped down, so you can use a global:

  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;